content: {-# LANGUAGE FlexibleContexts #-}
  -----------------------------------------------------------
  -- |
  -- Module      :  Database.HaskellDB.HDBC
  -- Copyright   :  HWT Group 2003, 
  --                Bjorn Bringert 2005-2006
  -- License     :  BSD-style
  -- 
  -- Maintainer  :  haskelldb-users@lists.sourceforge.net
  -- Stability   :  experimental
  -- Portability :  portable
  --
  -- HDBC interface for HaskellDB
  --
  -----------------------------------------------------------
  
  module Database.HaskellDB.HDBC (hdbcConnect) where
  
  import Database.HaskellDB
  import Database.HaskellDB.Database
  import Database.HaskellDB.Sql.Generate (SqlGenerator(..))
  import Database.HaskellDB.Sql.Print
  import Database.HaskellDB.PrimQuery
  import Database.HaskellDB.Query
  import Database.HaskellDB.FieldType
  
  import Database.HDBC as HDBC hiding (toSql)
  
  import Control.Monad.Trans (MonadIO, liftIO)
  import Data.Char (toLower)
  import Data.Map (Map)
  import qualified Data.Map as Map
  import Data.Maybe (fromMaybe)
  
  -- | Run an action on a HDBC IConnection and close the connection.
  hdbcConnect :: (MonadIO m, IConnection conn) => 
                 SqlGenerator
              -> IO conn -- ^ connection function
  	    -> (Database -> m a) -> m a
  hdbcConnect gen connect action = 
      do
      conn <- liftIO $ handleSqlError connect
      x <- action (mkDatabase gen conn)
      -- FIXME: should we really commit here?
      liftIO $ HDBC.commit conn
      liftIO $ handleSqlError (HDBC.disconnect conn)
      return x
  
  mkDatabase :: (IConnection conn) => SqlGenerator -> conn -> Database
  mkDatabase gen connection
      = Database { dbQuery	= hdbcQuery       gen connection,
      		 dbInsert	= hdbcInsert      gen connection,
  		 dbInsertQuery 	= hdbcInsertQuery gen connection,
  		 dbDelete	= hdbcDelete      gen connection,
  		 dbUpdate	= hdbcUpdate      gen connection,
  		 dbTables       = hdbcTables          connection,
  		 dbDescribe     = hdbcDescribe        connection,
  		 dbTransaction  = hdbcTransaction     connection,
                   dbCommit       = HDBC.commit         connection,
  		 dbCreateDB     = hdbcCreateDB    gen connection,
  		 dbCreateTable  = hdbcCreateTable gen connection,
  		 dbDropDB       = hdbcDropDB      gen connection,
  		 dbDropTable    = hdbcDropTable   gen connection
  	       }
  
  hdbcQuery :: (GetRec er vr, IConnection conn) => 
  	     SqlGenerator
            -> conn
  	  -> PrimQuery 
  	  -> Rel er
  	  -> IO [Record vr]
  hdbcQuery gen connection q rel = hdbcPrimQuery connection sql scheme rel
      where sql = show $ ppSql $ sqlQuery gen q
            scheme = attributes q
  
  hdbcInsert :: (IConnection conn) => SqlGenerator -> conn -> TableName -> Assoc -> IO ()
  hdbcInsert gen conn table assoc = 
      hdbcPrimExecute conn $ show $ ppInsert $ sqlInsert gen table assoc
  
  hdbcInsertQuery :: (IConnection conn) => SqlGenerator -> conn -> TableName -> PrimQuery -> IO ()
  hdbcInsertQuery gen conn table assoc = 
      hdbcPrimExecute conn $ show $ ppInsert $ sqlInsertQuery gen table assoc
  
  hdbcDelete :: (IConnection conn) => SqlGenerator -> conn -> TableName -> [PrimExpr] -> IO ()
  hdbcDelete gen conn table exprs = 
      hdbcPrimExecute conn $ show $ ppDelete $ sqlDelete gen table exprs
  
  hdbcUpdate :: (IConnection conn) => SqlGenerator -> conn -> TableName -> [PrimExpr] -> Assoc -> IO ()
  hdbcUpdate gen conn table criteria assigns = 
      hdbcPrimExecute conn $ show $ ppUpdate $ sqlUpdate gen table criteria assigns
  
  hdbcTables :: (IConnection conn) => conn -> IO [TableName]
  hdbcTables conn = handleSqlError $ HDBC.getTables conn
  
  hdbcDescribe :: (IConnection conn) => conn -> TableName -> IO [(Attribute,FieldDesc)]
  hdbcDescribe conn table = 
      handleSqlError $ do
                       cs <- HDBC.describeTable conn table
                       return [(n,colDescToFieldDesc c) | (n,c) <- cs]
  
  colDescToFieldDesc :: SqlColDesc -> FieldDesc
  colDescToFieldDesc c = (t, nullable)
      where 
      nullable = fromMaybe True (colNullable c)
      string = maybe StringT BStrT (colSize c)
      t = case colType c of
              SqlCharT          -> string
              SqlVarCharT       -> string
              SqlLongVarCharT   -> string
              SqlWCharT	      -> string
              SqlWVarCharT      -> string
              SqlWLongVarCharT  -> string
              SqlDecimalT       -> IntegerT
              SqlNumericT       -> IntegerT
              SqlSmallIntT      -> IntT
              SqlIntegerT	      -> IntT
              SqlRealT	      -> DoubleT
              SqlFloatT	      -> DoubleT
              SqlDoubleT	      -> DoubleT
              SqlBitT	      -> BoolT
              SqlTinyIntT	      -> IntT
              SqlBigIntT	      -> IntT
              SqlBinaryT	      -> string
              SqlVarBinaryT     -> string
              SqlLongVarBinaryT -> string
              SqlDateT          -> CalendarTimeT
              SqlTimeT          -> CalendarTimeT
              SqlTimestampT     -> LocalTimeT
              SqlUTCDateTimeT   -> CalendarTimeT
              SqlUTCTimeT       -> CalendarTimeT
              SqlTimeWithZoneT  -> CalendarTimeT
              SqlTimestampWithZoneT -> CalendarTimeT
              SqlIntervalT _    -> string
              SqlGUIDT          -> string
              SqlUnknownT _     -> string
  
  hdbcCreateDB :: (IConnection conn) => SqlGenerator -> conn -> String -> IO ()
  hdbcCreateDB gen conn name 
      = hdbcPrimExecute conn $ show $ ppCreate $ sqlCreateDB gen name
  
  hdbcCreateTable :: (IConnection conn) => SqlGenerator -> conn -> TableName -> [(Attribute,FieldDesc)] -> IO ()
  hdbcCreateTable gen conn name attrs
      = hdbcPrimExecute conn $ show $ ppCreate $ sqlCreateTable gen name attrs
  
  hdbcDropDB :: (IConnection conn) => SqlGenerator -> conn -> String -> IO ()
  hdbcDropDB gen conn name 
      = hdbcPrimExecute conn $ show $ ppDrop $ sqlDropDB gen name
  
  hdbcDropTable :: (IConnection conn) => SqlGenerator -> conn -> TableName -> IO ()
  hdbcDropTable gen conn name
      = hdbcPrimExecute conn $ show $ ppDrop $ sqlDropTable gen name
  
  -- | HDBC implementation of 'Database.dbTransaction'.
  hdbcTransaction :: (IConnection conn) => conn -> IO a -> IO a
  hdbcTransaction conn action = 
      handleSqlError $ HDBC.withTransaction conn (\_ -> action)
  
  
  -----------------------------------------------------------
  -- Primitive operations
  -----------------------------------------------------------
  
  type HDBCRow = Map String HDBC.SqlValue
  
  normalizeField :: String -> String
  normalizeField =  map toLower
  
  -- | Primitive query
  hdbcPrimQuery :: (GetRec er vr, IConnection conn) => 
  		 conn -- ^ Database connection.
  	      -> String     -- ^ SQL query
  	      -> Scheme     -- ^ List of field names to retrieve
  	      -> Rel er   -- ^ Phantom argument to get the return type right.
  	      -> IO [Record vr]    -- ^ Query results
  hdbcPrimQuery conn sql scheme rel = 
      do
      stmt <- handleSqlError $ HDBC.prepare conn sql
      handleSqlError $ HDBC.execute stmt []
      rows <- fetchNormalizedAllRowsAL stmt
      mapM (getRec hdbcGetInstances rel scheme) $ map Map.fromList rows
    where fetchNormalizedAllRowsAL sth =
            do
            names <- map normalizeField `fmap` getColumnNames sth
            rows <- fetchAllRows sth
            return $ map (zip names) rows
  
  -- | Primitive execute
  hdbcPrimExecute :: (IConnection conn) => conn -- ^ Database connection.
  		-> String     -- ^ SQL query.
  		-> IO ()
  hdbcPrimExecute conn sql = 
      do
      handleSqlError $ HDBC.run conn sql []
      return ()
  
  
  -----------------------------------------------------------
  -- Getting data from a statement
  -----------------------------------------------------------
  
  hdbcGetInstances :: GetInstances HDBCRow
  hdbcGetInstances = 
      GetInstances {
  		  getString        = hdbcGetValue
  		 , getInt          = hdbcGetValue
  		 , getInteger      = hdbcGetValue
  		 , getDouble       = hdbcGetValue
  		 , getBool         = hdbcGetValue
  		 , getCalendarTime = hdbcGetValue
  		 , getLocalTime    = hdbcGetValue
  		 }
  
  -- hdbcGetValue :: Data.Convertible.Base.Convertible SqlValue a
  --             => HDBCRow -> String -> IO (Maybe a)
  hdbcGetValue m f = case Map.lookup (normalizeField f) m of
                       Nothing -> fail $ "No such field " ++ f
                       Just x  -> return $ HDBC.fromSql x
  