{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Database.HDBC.Schema.MySQL
(
driverMySQL
)
where
import Prelude hiding (length)
import Language.Haskell.TH (TypeQ)
import Control.Applicative ((<$>), (<|>))
import Control.Monad (guard)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT)
import qualified Data.List as List
import Data.Map (fromList)
import Database.HDBC (IConnection, SqlValue)
import Database.Record (FromSql, ToSql)
import Database.HDBC.Record.Query (runQuery')
import Database.HDBC.Record.Persistable ()
import Database.HDBC.Schema.Driver ( TypeMap
, LogChan
, putVerbose
, failWith
, maybeIO
, hoistMaybe
, Driver
, driverConfig
, getFieldsWithMap
, getPrimaryKey
, emptyDriver
)
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
import Database.Relational.Schema.MySQLInfo.Config (config)
instance FromSql SqlValue Columns
instance ToSql SqlValue Columns
logPrefix :: String -> String
logPrefix = ("MySQL: " ++)
putLog :: LogChan -> String -> IO ()
putLog lchan = putVerbose lchan . logPrefix
compileError :: LogChan -> String -> MaybeT IO a
compileError lchan = failWith lchan . logPrefix
getPrimaryKey' :: IConnection conn
=> conn
-> LogChan
-> String
-> String
-> IO [String]
getPrimaryKey' conn lchan scm tbl = do
primCols <- runQuery' conn primaryKeyQuerySQL (scm, tbl)
let primaryKeyCols = normalizeColumn <$> primCols
putLog lchan $ "getPrimaryKey: primary key = " ++ show primaryKeyCols
return primaryKeyCols
getColumns' :: IConnection conn
=> TypeMap
-> conn
-> LogChan
-> String
-> String
-> IO ([(String, TypeQ)], [Int])
getColumns' tmap conn lchan scm tbl = maybeIO ([], []) id $ do
cols <- lift $ runQuery' conn columnsQuerySQL (scm, tbl)
guard (not $ null cols) <|>
compileError lchan
("getFields: No columns found: schema = " ++ scm
++ ", table = " ++ tbl)
let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols
lift . putLog lchan
$ "getFields: num of columns = " ++ show (List.length cols)
++ ", not null columns = " ++ show notNullIdxs
types <- mapM getType' cols
return (types, notNullIdxs)
where
getType' col =
hoistMaybe (getType (fromList tmap) col) <|>
compileError lchan
("Type mapping is not defined against MySQL type: "
++ Columns.dataType col)
driverMySQL :: IConnection conn => Driver conn
driverMySQL =
emptyDriver { getFieldsWithMap = getColumns' }
{ getPrimaryKey = getPrimaryKey' }
{ driverConfig = config }