module Database.HDBC.Schema.MySQL
(
driverMySQL
)
where
import Prelude hiding (length)
import Language.Haskell.TH (TypeQ)
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 = putStrLn . 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' }