{-# LANGUAGE TemplateHaskell #-}
module Database.Relational.Schema.PostgreSQL (
module Database.Relational.Schema.PostgreSQL.Config,
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, relationalQuery, Relation, query, query', relation', relation, union,
wheres, (.=.), (.>.), not', in', values, (!), fst', snd',
placeholder, asc, value, unsafeProjectSql, (><))
import Database.Relational.Schema.PostgreSQL.Config
import Database.Relational.Schema.PostgreSQL.PgNamespace (pgNamespace)
import qualified Database.Relational.Schema.PostgreSQL.PgNamespace as Namespace
import Database.Relational.Schema.PostgreSQL.PgClass (pgClass)
import qualified Database.Relational.Schema.PostgreSQL.PgClass as Class
import Database.Relational.Schema.PostgreSQL.PgConstraint (PgConstraint, pgConstraint)
import qualified Database.Relational.Schema.PostgreSQL.PgConstraint as Constraint
import Database.Relational.Schema.PostgreSQL.PgAttribute (PgAttribute, pgAttribute)
import qualified Database.Relational.Schema.PostgreSQL.PgAttribute as Attr
import Database.Relational.Schema.PostgreSQL.PgType (PgType(..), pgType)
import qualified Database.Relational.Schema.PostgreSQL.PgType as Type
import Control.Applicative ((<|>))
mapFromSqlDefault :: Map String TypeQ
mapFromSqlDefault :: Map String TypeQ
mapFromSqlDefault =
forall k a. Ord k => [(k, a)] -> Map k a
fromList [(String
"bool", [t| Bool |]),
(String
"char", [t| Char |]),
(String
"name", [t| String |]),
(String
"int8", [t| Int64 |]),
(String
"int2", [t| Int16 |]),
(String
"int4", [t| Int32 |]),
(String
"text", [t| String |]),
(String
"oid", [t| Int32 |]),
(String
"float4", [t| Float |]),
(String
"float8", [t| Double |]),
(String
"abstime", [t| LocalTime |]),
(String
"reltime", [t| NominalDiffTime |]),
(String
"tinterval", [t| DiffTime |]),
(String
"bpchar", [t| String |]),
(String
"varchar", [t| String |]),
(String
"uuid", [t| String |]),
(String
"date", [t| Day |]),
(String
"time", [t| TimeOfDay |]),
(String
"timestamp", [t| LocalTime |]),
(String
"timestamptz", [t| ZonedTime |]),
(String
"interval", [t| DiffTime |]),
(String
"timetz", [t| ZonedTime |])
]
normalizeColumn :: String -> String
normalizeColumn :: String -> String
normalizeColumn = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower
type Column = (PgAttribute, PgType)
notNull :: Column -> Bool
notNull :: Column -> Bool
notNull = PgAttribute -> Bool
Attr.attnotnull forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
getType :: Map String TypeQ
-> Column
-> Maybe (String, TypeQ)
getType :: Map String TypeQ -> Column -> Maybe (String, TypeQ)
getType Map String TypeQ
mapFromSql column :: Column
column@(PgAttribute
pgAttr, PgType
pgTyp) = do
TypeQ
typ <- (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key Map String TypeQ
mapFromSql
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key Map String TypeQ
mapFromSqlDefault)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
normalizeColumn forall a b. (a -> b) -> a -> b
$ PgAttribute -> String
Attr.attname PgAttribute
pgAttr,
forall {m :: * -> *}. Quote m => m Type -> m Type
mayNull TypeQ
typ)
where key :: String
key = PgType -> String
Type.typname PgType
pgTyp
mayNull :: m Type -> m Type
mayNull m Type
typ = if Column -> Bool
notNull Column
column
then m Type
typ
else [t| Maybe $typ |]
relOidRelation :: Relation (String, String) Int32
relOidRelation :: Relation (String, String) Int32
relOidRelation = forall p r. SimpleQuery p r -> Relation p r
relation' forall a b. (a -> b) -> a -> b
$ do
Record Flat PgNamespace
nsp <- forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () PgNamespace
pgNamespace
Record Flat PgClass
cls <- forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () PgClass
pgClass
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat PgClass
cls forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgClass Int32
Class.relnamespace' forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat PgNamespace
nsp forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgNamespace Int32
Namespace.oid'
(PlaceHolders String
nspP, ()) <- forall t c (m :: * -> *) a.
(PersistableWidth t, SqlContext c, Monad m) =>
(Record c t -> m a) -> m (PlaceHolders t, a)
placeholder (\Record Flat String
ph -> forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat PgNamespace
nsp forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgNamespace String
Namespace.nspname' forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat String
ph)
(PlaceHolders String
relP, ()) <- forall t c (m :: * -> *) a.
(PersistableWidth t, SqlContext c, Monad m) =>
(Record c t -> m a) -> m (PlaceHolders t, a)
placeholder (\Record Flat String
ph -> forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat PgClass
cls forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgClass String
Class.relname' forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat String
ph)
forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders String
nspP forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< PlaceHolders String
relP, Record Flat PgClass
cls forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgClass Int32
Class.oid')
attributeRelation :: Relation (String, String) PgAttribute
attributeRelation :: Relation (String, String) PgAttribute
attributeRelation = forall p r. SimpleQuery p r -> Relation p r
relation' forall a b. (a -> b) -> a -> b
$ do
(PlaceHolders (String, String)
ph, Record Flat Int32
reloid) <- forall (m :: * -> *) p r.
MonadQuery m =>
Relation p r -> m (PlaceHolders p, Record Flat r)
query' Relation (String, String) Int32
relOidRelation
Record Flat PgAttribute
att <- forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () PgAttribute
pgAttribute
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat PgAttribute
att forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgAttribute Int32
Attr.attrelid' forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat Int32
reloid
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat PgAttribute
att forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgAttribute Int16
Attr.attnum' forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.>. forall t c. (LiteralSQL t, OperatorContext c) => t -> Record c t
value Int16
0
forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders (String, String)
ph, Record Flat PgAttribute
att)
columnRelation :: Relation (String, String) Column
columnRelation :: Relation (String, String) Column
columnRelation = forall p r. SimpleQuery p r -> Relation p r
relation' forall a b. (a -> b) -> a -> b
$ do
(PlaceHolders (String, String)
ph, Record Flat PgAttribute
att) <- forall (m :: * -> *) p r.
MonadQuery m =>
Relation p r -> m (PlaceHolders p, Record Flat r)
query' Relation (String, String) PgAttribute
attributeRelation
Record Flat PgType
typ <- forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () PgType
pgType
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat PgAttribute
att forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgAttribute Int32
Attr.atttypid' forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat PgType
typ forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgType Int32
Type.oid'
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat PgType
typ forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgType Char
Type.typtype' forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. forall t c. (LiteralSQL t, OperatorContext c) => t -> Record c t
value Char
'b'
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ forall c.
OperatorContext c =>
Record c (Maybe Bool) -> Record c (Maybe Bool)
not' forall a b. (a -> b) -> a -> b
$ Record Flat PgType
typ forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgType Char
Type.typcategory' forall c t.
OperatorContext c =>
Record c t -> RecordList (Record c) t -> Record c (Maybe Bool)
`in'`
forall t c.
(LiteralSQL t, OperatorContext c) =>
[t] -> RecordList (Record c) t
values
[ Char
'C'
, Char
'P'
, Char
'X'
]
forall (m :: * -> *) c t. Monad m => Record c t -> Orderings c m ()
asc forall a b. (a -> b) -> a -> b
$ Record Flat PgAttribute
att forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgAttribute Int16
Attr.attnum'
forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders (String, String)
ph, Record Flat PgAttribute
att forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< Record Flat PgType
typ)
columnQuerySQL :: Query (String, String) Column
columnQuerySQL :: Query (String, String) Column
columnQuerySQL = forall p r. Relation p r -> Query p r
relationalQuery Relation (String, String) Column
columnRelation
primaryKeyLengthRelation :: Relation (String, String) Int32
primaryKeyLengthRelation :: Relation (String, String) Int32
primaryKeyLengthRelation = forall p r. SimpleQuery p r -> Relation p r
relation' forall a b. (a -> b) -> a -> b
$ do
(PlaceHolders (String, String)
ph, Record Flat Int32
reloid) <- forall (m :: * -> *) p r.
MonadQuery m =>
Relation p r -> m (PlaceHolders p, Record Flat r)
query' Relation (String, String) Int32
relOidRelation
Record Flat PgConstraint
con <- forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () PgConstraint
pgConstraint
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat PgConstraint
con forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgConstraint Int32
Constraint.conrelid' forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat Int32
reloid
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat PgConstraint
con forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgConstraint Char
Constraint.contype' forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. forall t c. (LiteralSQL t, OperatorContext c) => t -> Record c t
value Char
'p'
forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders (String, String)
ph, forall c t. SqlContext c => String -> Record c t
unsafeProjectSql String
"array_length (conkey, 1)")
primaryKeyLengthQuerySQL :: Query (String, String) Int32
primaryKeyLengthQuerySQL :: Query (String, String) Int32
primaryKeyLengthQuerySQL = forall p r. Relation p r -> Query p r
relationalQuery Relation (String, String) Int32
primaryKeyLengthRelation
constraintColRelation :: Int32 -> Relation () (PgConstraint, (Int16, Int32))
constraintColRelation :: Int32 -> Relation () (PgConstraint, (Int16, Int32))
constraintColRelation Int32
i = forall r. QuerySimple (Record Flat r) -> Relation () r
relation forall a b. (a -> b) -> a -> b
$ do
Record Flat PgConstraint
con <- forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () PgConstraint
pgConstraint
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Record Flat PgConstraint
con forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< (forall c t. SqlContext c => String -> Record c t
unsafeProjectSql (String
"conkey[" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int32
i forall a. [a] -> [a] -> [a]
++ String
"]") forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< forall t c. (LiteralSQL t, OperatorContext c) => t -> Record c t
value Int32
i)
constraintColExpandRelation :: Int32 -> Relation () (PgConstraint, (Int16, Int32))
constraintColExpandRelation :: Int32 -> Relation () (PgConstraint, (Int16, Int32))
constraintColExpandRelation Int32
n =
forall a. (a -> a -> a) -> [a] -> a
foldl1' forall a. Relation () a -> Relation () a -> Relation () a
union [Int32 -> Relation () (PgConstraint, (Int16, Int32))
constraintColRelation Int32
i | Int32
i <- [Int32
1..Int32
n] ]
primaryKeyRelation :: Int32 -> Relation (String, String) String
primaryKeyRelation :: Int32 -> Relation (String, String) String
primaryKeyRelation Int32
n = forall p r. SimpleQuery p r -> Relation p r
relation' forall a b. (a -> b) -> a -> b
$ do
(PlaceHolders (String, String)
ph, Record Flat PgAttribute
att) <- forall (m :: * -> *) p r.
MonadQuery m =>
Relation p r -> m (PlaceHolders p, Record Flat r)
query' Relation (String, String) PgAttribute
attributeRelation
Record Flat (PgConstraint, (Int16, Int32))
conEx <- forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query (Int32 -> Relation () (PgConstraint, (Int16, Int32))
constraintColExpandRelation Int32
n)
let con :: Record Flat PgConstraint
con = Record Flat (PgConstraint, (Int16, Int32))
conEx forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! forall a b. (PersistableWidth a, PersistableWidth b) => Pi (a, b) a
fst'
col' :: Record Flat (Int16, Int32)
col' = Record Flat (PgConstraint, (Int16, Int32))
conEx forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! forall a b. (PersistableWidth a, PersistableWidth b) => Pi (a, b) b
snd'
keyIx :: Record Flat Int16
keyIx = Record Flat (Int16, Int32)
col' forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! forall a b. (PersistableWidth a, PersistableWidth b) => Pi (a, b) a
fst'
keyN :: Record Flat Int32
keyN = Record Flat (Int16, Int32)
col' forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! forall a b. (PersistableWidth a, PersistableWidth b) => Pi (a, b) b
snd'
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat PgConstraint
con forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgConstraint Int32
Constraint.conrelid' forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat PgAttribute
att forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgAttribute Int32
Attr.attrelid'
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat Int16
keyIx forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat PgAttribute
att forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgAttribute Int16
Attr.attnum'
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat PgConstraint
con forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgConstraint Char
Constraint.contype' forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. forall t c. (LiteralSQL t, OperatorContext c) => t -> Record c t
value Char
'p'
forall (m :: * -> *) c t. Monad m => Record c t -> Orderings c m ()
asc forall a b. (a -> b) -> a -> b
$ Record Flat Int32
keyN
forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders (String, String)
ph, Record Flat PgAttribute
att forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgAttribute String
Attr.attname')
primaryKeyQuerySQL :: Int32 -> Query (String, String) String
primaryKeyQuerySQL :: Int32 -> Query (String, String) String
primaryKeyQuerySQL = forall p r. Relation p r -> Query p r
relationalQuery forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Relation (String, String) String
primaryKeyRelation