module Database.HDBC.Schema.MySQL
(
driverMySQL
)
where
import Prelude hiding (length)
import Language.Haskell.TH (TypeQ)
import Language.Haskell.TH.Lib.Extra (reportMessage)
import qualified Data.List as List
import Data.Map (fromList)
import Database.HDBC (IConnection, SqlValue)
import Database.HDBC.Record.Query (runQuery')
import Database.HDBC.Record.Persistable ()
import Database.HDBC.Schema.Driver ( TypeMap
, Driver
, getFieldsWithMap
, getPrimaryKey
, emptyDriver
)
import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined)
import Database.Relational.Schema.MySQL ( normalizeColumn
, notNull
, getType
, columnsQuerySQL
, primaryKeyQuerySQL
)
import Database.Relational.Schema.MySQLInfo.Columns (Columns)
import qualified Database.Relational.Schema.MySQLInfo.Columns as Columns
$(makeRecordPersistableWithSqlTypeDefaultFromDefined [t| SqlValue |] ''Columns)
logPrefix :: String -> String
logPrefix = ("MySQL: " ++)
putLog :: String -> IO ()
putLog = reportMessage . logPrefix
compileErrorIO :: String -> IO a
compileErrorIO = fail . logPrefix
getPrimaryKey' :: IConnection conn
=> conn
-> String
-> String
-> IO [String]
getPrimaryKey' conn scm tbl = do
primCols <- runQuery' conn primaryKeyQuerySQL (scm, tbl)
let primaryKeyCols = normalizeColumn `fmap` primCols
putLog $ "getPrimaryKey: primary key = " ++ show primaryKeyCols
return primaryKeyCols
getFields' :: IConnection conn
=> TypeMap
-> conn
-> String
-> String
-> IO ([(String, TypeQ)], [Int])
getFields' tmap conn scm tbl = do
cols <- runQuery' conn columnsQuerySQL (scm, tbl)
case cols of
[] -> compileErrorIO
$ "getFields: No columns found: schema = " ++ scm
++ ", table = " ++ tbl
_ -> return ()
let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols
putLog
$ "getFields: num of columns = " ++ show (List.length cols)
++ ", not null columns = " ++ show notNullIdxs
types <- mapM getType' cols
return (types, notNullIdxs)
where
getType' col =
case getType (fromList tmap) col of
Nothing -> compileErrorIO
$ "Type mapping is not defined against MySQL type: "
++ Columns.dataType col
Just p -> return p
driverMySQL :: IConnection conn => Driver conn
driverMySQL =
emptyDriver { getFieldsWithMap = getFields' }
{ getPrimaryKey = getPrimaryKey' }