module Database.HDBC.Schema.PostgreSQL (
driverPostgreSQL
) where
import Language.Haskell.TH (TypeQ)
import Data.Char (toLower)
import Data.Map (fromList)
import Control.Monad (when)
import Database.HDBC (IConnection, SqlValue)
import Language.Haskell.TH.Lib.Extra (reportMessage)
import Database.HDBC.Record.Query (runQuery')
import Database.HDBC.Record.Persistable ()
import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined)
import Database.Relational.Schema.PostgreSQL
(normalizeColumn, notNull, getType, columnQuerySQL,
primaryKeyLengthQuerySQL, primaryKeyQuerySQL)
import Database.Relational.Schema.PgCatalog.PgAttribute (PgAttribute)
import Database.Relational.Schema.PgCatalog.PgType (PgType)
import qualified Database.Relational.Schema.PgCatalog.PgType as Type
import Database.HDBC.Schema.Driver
(TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver)
$(makeRecordPersistableWithSqlTypeDefaultFromDefined
[t| SqlValue |] ''PgAttribute)
$(makeRecordPersistableWithSqlTypeDefaultFromDefined
[t| SqlValue |] ''PgType)
logPrefix :: String -> String
logPrefix = ("PostgreSQL: " ++)
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
let scm = map toLower scm'
tbl = map toLower tbl'
mayKeyLen <- runQuery' conn primaryKeyLengthQuerySQL (scm, tbl)
case mayKeyLen of
[] -> do
putLog "getPrimaryKey: Primary key not found."
return []
[keyLen] -> do
primCols <- runQuery' conn (primaryKeyQuerySQL keyLen) (scm, tbl)
let primaryKeyCols = normalizeColumn `fmap` primCols
putLog $ "getPrimaryKey: primary key = " ++ show primaryKeyCols
return primaryKeyCols
_:_:_ -> do
putLog "getPrimaryKey: Fail to detect primary key. Something wrong."
return []
getColumns' :: IConnection conn
=> TypeMap
-> conn
-> String
-> String
-> IO ([(String, TypeQ)], [Int])
getColumns' tmap conn scm' tbl' = do
let scm = map toLower scm'
tbl = map toLower tbl'
cols <- runQuery' conn columnQuerySQL (scm, tbl)
when (null cols) . compileErrorIO
$ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl
let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols
putLog
$ "getFields: num of columns = " ++ show (length cols)
++ ", not null columns = " ++ show notNullIdxs
let getType' col = case getType (fromList tmap) col of
Nothing -> compileErrorIO
$ "Type mapping is not defined against PostgreSQL type: " ++ Type.typname (snd col)
Just p -> return p
types <- mapM getType' cols
return (types, notNullIdxs)
driverPostgreSQL :: IConnection conn => Driver conn
driverPostgreSQL =
emptyDriver { getFieldsWithMap = getColumns' }
{ getPrimaryKey = getPrimaryKey' }