{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Database.HDBC.Schema.PostgreSQL (
driverPostgreSQL
) where
import Language.Haskell.TH (TypeQ)
import Data.Char (toLower)
import Data.Map (fromList)
import Control.Applicative ((<$>), (<|>))
import Control.Monad (guard)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT)
import Database.HDBC (IConnection, SqlValue)
import Database.HDBC.Record.Query (runQuery')
import Database.HDBC.Record.Persistable ()
import Database.Record (FromSql, ToSql)
import Database.Relational.Schema.PostgreSQL
(normalizeColumn, notNull, getType, columnQuerySQL,
primaryKeyLengthQuerySQL, primaryKeyQuerySQL)
import Database.Relational.Schema.PostgreSQL.PgAttribute (PgAttribute)
import Database.Relational.Schema.PostgreSQL.PgType (PgType)
import qualified Database.Relational.Schema.PostgreSQL.PgType as Type
import Database.Relational.Schema.PostgreSQL (config)
import Database.HDBC.Schema.Driver
(TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe,
Driver, driverConfig, getFieldsWithMap, getPrimaryKey, emptyDriver)
instance FromSql SqlValue PgAttribute
instance ToSql SqlValue PgAttribute
instance FromSql SqlValue PgType
instance ToSql SqlValue PgType
logPrefix :: String -> String
logPrefix :: String -> String
logPrefix = ("PostgreSQL: " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
putLog :: LogChan -> String -> IO ()
putLog :: LogChan -> String -> IO ()
putLog lchan :: LogChan
lchan = LogChan -> String -> IO ()
putVerbose LogChan
lchan (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
logPrefix
compileError :: LogChan -> String -> MaybeT IO a
compileError :: LogChan -> String -> MaybeT IO a
compileError lchan :: LogChan
lchan = LogChan -> String -> MaybeT IO a
forall a. LogChan -> String -> MaybeT IO a
failWith LogChan
lchan (String -> MaybeT IO a)
-> (String -> String) -> String -> MaybeT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
logPrefix
getPrimaryKey' :: IConnection conn
=> conn
-> LogChan
-> String
-> String
-> IO [String]
getPrimaryKey' :: conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey' conn :: conn
conn lchan :: LogChan
lchan scm' :: String
scm' tbl' :: String
tbl' = do
let scm :: String
scm = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
scm'
tbl :: String
tbl = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
tbl'
[Int32]
mayKeyLen <- conn
-> Query (String, String) Int32 -> (String, String) -> IO [Int32]
forall conn p a.
(IConnection conn, ToSql SqlValue p, FromSql SqlValue a) =>
conn -> Query p a -> p -> IO [a]
runQuery' conn
conn Query (String, String) Int32
primaryKeyLengthQuerySQL (String
scm, String
tbl)
case [Int32]
mayKeyLen of
[] ->
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
[keyLen :: Int32
keyLen] -> do
[String]
primCols <- conn
-> Query (String, String) String -> (String, String) -> IO [String]
forall conn p a.
(IConnection conn, ToSql SqlValue p, FromSql SqlValue a) =>
conn -> Query p a -> p -> IO [a]
runQuery' conn
conn (Int32 -> Query (String, String) String
primaryKeyQuerySQL Int32
keyLen) (String
scm, String
tbl)
let primaryKeyCols :: [String]
primaryKeyCols = String -> String
normalizeColumn (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
primCols
LogChan -> String -> IO ()
putLog LogChan
lchan (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "getPrimaryKey: primary key = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
primaryKeyCols
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
primaryKeyCols
_:_:_ -> do
LogChan -> String -> IO ()
putLog LogChan
lchan "getPrimaryKey: Fail to detect primary key. Something wrong."
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
getColumns' :: IConnection conn
=> TypeMap
-> conn
-> LogChan
-> String
-> String
-> IO ([(String, TypeQ)], [Int])
getColumns' :: TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getColumns' tmap :: TypeMap
tmap conn :: conn
conn lchan :: LogChan
lchan scm' :: String
scm' tbl' :: String
tbl' = (TypeMap, [Int])
-> ((TypeMap, [Int]) -> (TypeMap, [Int]))
-> MaybeT IO (TypeMap, [Int])
-> IO (TypeMap, [Int])
forall b a. b -> (a -> b) -> MaybeT IO a -> IO b
maybeIO ([], []) (TypeMap, [Int]) -> (TypeMap, [Int])
forall a. a -> a
id (MaybeT IO (TypeMap, [Int]) -> IO (TypeMap, [Int]))
-> MaybeT IO (TypeMap, [Int]) -> IO (TypeMap, [Int])
forall a b. (a -> b) -> a -> b
$ do
let scm :: String
scm = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
scm'
tbl :: String
tbl = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
tbl'
[Column]
cols <- IO [Column] -> MaybeT IO [Column]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [Column] -> MaybeT IO [Column])
-> IO [Column] -> MaybeT IO [Column]
forall a b. (a -> b) -> a -> b
$ conn
-> Query (String, String) Column -> (String, String) -> IO [Column]
forall conn p a.
(IConnection conn, ToSql SqlValue p, FromSql SqlValue a) =>
conn -> Query p a -> p -> IO [a]
runQuery' conn
conn Query (String, String) Column
columnQuerySQL (String
scm, String
tbl)
Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Column] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Column]
cols) MaybeT IO () -> MaybeT IO () -> MaybeT IO ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
LogChan -> String -> MaybeT IO ()
forall a. LogChan -> String -> MaybeT IO a
compileError LogChan
lchan ("getFields: No columns found: schema = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
scm String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", table = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tbl)
let notNullIdxs :: [Int]
notNullIdxs = ((Int, Column) -> Int) -> [(Int, Column)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Column) -> Int
forall a b. (a, b) -> a
fst ([(Int, Column)] -> [Int])
-> ([Column] -> [(Int, Column)]) -> [Column] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Column) -> Bool) -> [(Int, Column)] -> [(Int, Column)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Column -> Bool
notNull (Column -> Bool)
-> ((Int, Column) -> Column) -> (Int, Column) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Column) -> Column
forall a b. (a, b) -> b
snd) ([(Int, Column)] -> [(Int, Column)])
-> ([Column] -> [(Int, Column)]) -> [Column] -> [(Int, Column)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Column] -> [(Int, Column)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] ([Column] -> [Int]) -> [Column] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Column]
cols
IO () -> MaybeT IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> MaybeT IO ())
-> (String -> IO ()) -> String -> MaybeT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogChan -> String -> IO ()
putLog LogChan
lchan
(String -> MaybeT IO ()) -> String -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ "getFields: num of columns = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Column] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Column]
cols)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", not null columns = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. Show a => a -> String
show [Int]
notNullIdxs
let getType' :: Column -> MaybeT IO (String, TypeQ)
getType' col :: Column
col =
Maybe (String, TypeQ) -> MaybeT IO (String, TypeQ)
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
hoistMaybe (Map String TypeQ -> Column -> Maybe (String, TypeQ)
getType (TypeMap -> Map String TypeQ
forall k a. Ord k => [(k, a)] -> Map k a
fromList TypeMap
tmap) Column
col) MaybeT IO (String, TypeQ)
-> MaybeT IO (String, TypeQ) -> MaybeT IO (String, TypeQ)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
LogChan -> String -> MaybeT IO (String, TypeQ)
forall a. LogChan -> String -> MaybeT IO a
compileError LogChan
lchan ("Type mapping is not defined against PostgreSQL type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PgType -> String
Type.typname (Column -> PgType
forall a b. (a, b) -> b
snd Column
col))
TypeMap
types <- (Column -> MaybeT IO (String, TypeQ))
-> [Column] -> MaybeT IO TypeMap
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Column -> MaybeT IO (String, TypeQ)
getType' [Column]
cols
(TypeMap, [Int]) -> MaybeT IO (TypeMap, [Int])
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeMap
types, [Int]
notNullIdxs)
driverPostgreSQL :: IConnection conn => Driver conn
driverPostgreSQL :: Driver conn
driverPostgreSQL =
Driver conn
forall conn. IConnection conn => Driver conn
emptyDriver { getFieldsWithMap :: TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getFieldsWithMap = TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
forall conn.
IConnection conn =>
TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getColumns' }
{ getPrimaryKey :: conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey = conn -> LogChan -> String -> String -> IO [String]
forall conn.
IConnection conn =>
conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey' }
{ driverConfig :: Config
driverConfig = Config
config }