module Database.Relational.Schema.PostgreSQL (
Column,
normalizeColumn, notNull, getType,
columnQuerySQL,
primaryKeyLengthQuerySQL, primaryKeyQuerySQL
) where
import Prelude hiding (or)
import Language.Haskell.TH (TypeQ)
import Data.Int (Int16, Int32, Int64)
import Data.Char (toLower)
import Data.List (foldl1')
import Data.Map (Map, fromList)
import qualified Data.Map as Map
import Data.Time
(DiffTime, NominalDiffTime,
LocalTime, ZonedTime, Day, TimeOfDay)
import Database.Relational.Query
(Query, relationalQuery, Relation, query, query', relation', relation, union,
wheres, (.=.), (.>.), in', values, (!), fst', snd',
placeholder, asc, value, unsafeProjectSql, (><))
import Database.Relational.Schema.PgCatalog.PgNamespace (pgNamespace)
import qualified Database.Relational.Schema.PgCatalog.PgNamespace as Namespace
import Database.Relational.Schema.PgCatalog.PgClass (pgClass)
import qualified Database.Relational.Schema.PgCatalog.PgClass as Class
import Database.Relational.Schema.PgCatalog.PgConstraint (PgConstraint, pgConstraint)
import qualified Database.Relational.Schema.PgCatalog.PgConstraint as Constraint
import Database.Relational.Schema.PgCatalog.PgAttribute (PgAttribute, pgAttribute)
import qualified Database.Relational.Schema.PgCatalog.PgAttribute as Attr
import Database.Relational.Schema.PgCatalog.PgType (PgType(..), pgType)
import qualified Database.Relational.Schema.PgCatalog.PgType as Type
import Control.Applicative ((<|>))
mapFromSqlDefault :: Map String TypeQ
mapFromSqlDefault =
fromList [("bool", [t| Bool |]),
("char", [t| Char |]),
("name", [t| String |]),
("int8", [t| Int64 |]),
("int2", [t| Int16 |]),
("int4", [t| Int32 |]),
("text", [t| String |]),
("oid", [t| Int32 |]),
("float4", [t| Float |]),
("float8", [t| Double |]),
("abstime", [t| LocalTime |]),
("reltime", [t| NominalDiffTime |]),
("tinterval", [t| DiffTime |]),
("bpchar", [t| String |]),
("varchar", [t| String |]),
("date", [t| Day |]),
("time", [t| TimeOfDay |]),
("timestamp", [t| LocalTime |]),
("timestamptz", [t| ZonedTime |]),
("interval", [t| DiffTime |]),
("timetz", [t| ZonedTime |])
]
normalizeColumn :: String -> String
normalizeColumn = map toLower
type Column = (PgAttribute, PgType)
notNull :: Column -> Bool
notNull = Attr.attnotnull . fst
getType :: Map String TypeQ
-> Column
-> Maybe (String, TypeQ)
getType mapFromSql column@(pgAttr, pgTyp) = do
typ <- (Map.lookup key mapFromSql
<|>
Map.lookup key mapFromSqlDefault)
return (normalizeColumn $ Attr.attname pgAttr,
mayNull typ)
where key = Type.typname pgTyp
mayNull typ = if notNull column
then typ
else [t| Maybe $typ |]
relOidRelation :: Relation (String, String) Int32
relOidRelation = relation' $ do
nsp <- query pgNamespace
cls <- query pgClass
wheres $ cls ! Class.relnamespace' .=. nsp ! Namespace.oid'
(nspP, ()) <- placeholder (\ph -> wheres $ nsp ! Namespace.nspname' .=. ph)
(relP, ()) <- placeholder (\ph -> wheres $ cls ! Class.relname' .=. ph)
return (nspP >< relP, cls ! Class.oid')
attributeRelation :: Relation (String, String) PgAttribute
attributeRelation = relation' $ do
(ph, reloid) <- query' relOidRelation
att <- query pgAttribute
wheres $ att ! Attr.attrelid' .=. reloid
wheres $ att ! Attr.attnum' .>. value 0
return (ph, att)
columnRelation :: Relation (String, String) Column
columnRelation = relation' $ do
(ph, att) <- query' attributeRelation
typ <- query pgType
wheres $ att ! Attr.atttypid' .=. typ ! Type.oid'
wheres $ typ ! Type.typtype' .=. value 'b'
wheres $ typ ! Type.typcategory' `in'` values [ 'B'
, 'D'
, 'I'
, 'N'
, 'S'
, 'T'
]
asc $ att ! Attr.attnum'
return (ph, att >< typ)
columnQuerySQL :: Query (String, String) Column
columnQuerySQL = relationalQuery columnRelation
primaryKeyLengthRelation :: Relation (String, String) Int32
primaryKeyLengthRelation = relation' $ do
(ph, reloid) <- query' relOidRelation
con <- query pgConstraint
wheres $ con ! Constraint.conrelid' .=. reloid
wheres $ con ! Constraint.contype' .=. value 'p'
return (ph, unsafeProjectSql "array_length (conkey, 1)")
primaryKeyLengthQuerySQL :: Query (String, String) Int32
primaryKeyLengthQuerySQL = relationalQuery primaryKeyLengthRelation
constraintColRelation :: Int32 -> Relation () (PgConstraint, (Int16, Int32))
constraintColRelation i = relation $ do
con <- query pgConstraint
return $ con >< (unsafeProjectSql ("conkey[" ++ show i ++ "]") >< value i)
constraintColExpandRelation :: Int32 -> Relation () (PgConstraint, (Int16, Int32))
constraintColExpandRelation n =
foldl1' union [constraintColRelation i | i <- [1..n] ]
primaryKeyRelation :: Int32 -> Relation (String, String) String
primaryKeyRelation n = relation' $ do
(ph, att) <- query' attributeRelation
conEx <- query (constraintColExpandRelation n)
let con = conEx ! fst'
col' = conEx ! snd'
keyIx = col' ! fst'
keyN = col' ! snd'
wheres $ con ! Constraint.conrelid' .=. att ! Attr.attrelid'
wheres $ keyIx .=. att ! Attr.attnum'
wheres $ con ! Constraint.contype' .=. value 'p'
asc $ keyN
return (ph, att ! Attr.attname')
primaryKeyQuerySQL :: Int32 -> Query (String, String) String
primaryKeyQuerySQL = relationalQuery . primaryKeyRelation