{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Database.Schema.PostgreSQL.Pure
( driver
) where
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 Data.Char (toLower)
import Data.Map (fromList)
import Database.Relational.PostgreSQL.Pure.Query (runQuery')
import Database.Relational.Schema.PostgreSQL (config, getType, normalizeColumn, notNull,
primaryKeyLengthQuerySQL, primaryKeyQuerySQL)
import qualified Database.Relational.Schema.PostgreSQL as Schema
import Database.Relational.Schema.PostgreSQL.PgAttribute (PgAttribute (PgAttribute))
import Database.Relational.Schema.PostgreSQL.PgType (PgType (PgType))
import qualified Database.Relational.Schema.PostgreSQL.PgType as Type
import Database.Schema.PostgreSQL.Pure.Driver (Driver, LogChan, TypeMap, driverConfig, emptyDriver,
failWith, getFieldsWithMap, getPrimaryKey,
hoistMaybe, maybeIO, putVerbose)
import Data.Tuple.Homotuple.Only ()
import Data.Tuple.List.Only ()
import Database.PostgreSQL.Pure (Connection)
import Database.PostgreSQL.Pure.Oid (Oid (Oid))
import Database.Relational (Query)
import GHC.Int (Int16, Int32)
import Unsafe.Coerce (unsafeCoerce)
type Column = (Oid, String, Oid, Int32, Int16, Int16, Int32, Int32, Int32, Bool, Char, Char, Bool, Bool, Bool, Bool, Int32, Oid, Oid, String, Oid, Oid, Int16, Bool, Char, Char, Bool, Bool, Char, Oid, Oid, Oid, Char, Char, Bool, Oid, Int32, Int32, Oid, Maybe String)
originalColumn :: Column -> Schema.Column
originalColumn (Oid i0, i1, Oid i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, Oid i17, Oid i100, i101, Oid i102, Oid i103, i104, i105, i106, i107, i108, i109, i110, Oid i111, Oid i112, Oid i113, i114, i115, i116, Oid i117, i118, i119, Oid i120, i121) =
( PgAttribute i0 i1 i2 i3 i4 i5 i6 i7 i8 i9 i10 i11 i12 i13 i14 i15 i16 i17
, PgType i100 i101 i102 i103 i104 i105 i106 i107 i108 i109 i110 i111 i112 i113 i114 i115 i116 i117 i118 i119 i120 i121
)
logPrefix :: String -> String
logPrefix = ("PostgreSQL: " ++)
putLog :: LogChan -> String -> IO ()
putLog lchan = putVerbose lchan . logPrefix
compileError :: LogChan -> String -> MaybeT IO a
compileError lchan = failWith lchan . logPrefix
getPrimaryKey' :: Connection
-> LogChan
-> String
-> String
-> IO [String]
getPrimaryKey' conn lchan scm' tbl' = do
let scm = map toLower scm'
tbl = map toLower tbl'
mayKeyLen <- runQuery' conn primaryKeyLengthQuerySQL (scm, tbl)
case mayKeyLen of
[] ->
return []
[keyLen] -> do
primCols <- runQuery' conn (primaryKeyQuerySQL keyLen) (scm, tbl)
let primaryKeyCols = normalizeColumn <$> primCols
putLog lchan $ "getPrimaryKey: primary key = " ++ show primaryKeyCols
return primaryKeyCols
_:_:_ -> do
putLog lchan "getPrimaryKey: Fail to detect primary key. Something wrong."
return []
getColumns' :: TypeMap
-> Connection
-> LogChan
-> String
-> String
-> IO ([(String, TypeQ)], [Int])
getColumns' tmap conn lchan scm' tbl' = maybeIO ([], []) id $ do
let scm = map toLower scm'
tbl = map toLower tbl'
columnQuerySQL :: Query (String, String) Column
columnQuerySQL = unsafeCoerce Schema.columnQuerySQL
cols <- lift $ (originalColumn <$>) <$> runQuery' conn columnQuerySQL (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 (length cols)
++ ", not null columns = " ++ show notNullIdxs
let getType' col =
hoistMaybe (getType (fromList tmap) col) <|>
compileError lchan ("Type mapping is not defined against PostgreSQL type: " ++ Type.typname (snd col))
types <- mapM getType' cols
return (types, notNullIdxs)
driver :: Driver
driver =
emptyDriver { getFieldsWithMap = getColumns' }
{ getPrimaryKey = getPrimaryKey' }
{ driverConfig = config }