{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      : Database.Relational.Schema.PostgreSQL
-- Copyright   : 2013-2019 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module implements queries to get
-- table schema and table constraint information
-- from system catalog of PostgreSQL.
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 ((<|>))


-- | Mapping between type in PostgreSQL and Haskell type.
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 |]),
            -- ("regproc",      [t| Int32 |]),
            (String
"text",         [t| String |]),
            (String
"oid",          [t| Int32 |]),
            -- ("pg_node_tree", [t| String |]),
            (String
"float4",       [t| Float |]),
            (String
"float8",       [t| Double |]),
            (String
"abstime",      [t| LocalTime |]),
            (String
"reltime",      [t| NominalDiffTime |]),
            (String
"tinterval",    [t| DiffTime |]),
            -- ("money",        [t| Decimal |]),
            (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 |])

            -- ("bit", [t|  |]),
            -- ("varbit", [t|  |]),
            -- ("numeric", [t| Decimal |])
           ]

-- | Normalize column name string to query PostgreSQL system catalog.
normalizeColumn :: String -> String
normalizeColumn :: String -> String
normalizeColumn =  forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower

-- | Type to represent Column information.
type Column = (PgAttribute, PgType)

-- | Not-null attribute information of column.
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

-- | Get column normalized name and column Haskell type.
getType :: Map String TypeQ      -- ^ Type mapping specified by user
        -> Column                -- ^ Column info in system catalog
        -> Maybe (String, TypeQ) -- ^ Result normalized name and mapped Haskell type
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 |]

-- | 'Relation' to query PostgreSQL relation oid from schema name and table name.
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')

-- | 'Relation' to query column attribute from schema name and table name.
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)

-- | 'Relation' to query 'Column' from schema name and table name.
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'  -- 'b': base type only

  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' -- Composite types
                  , Char
'P' -- Pseudo-types
                  , Char
'X' -- unknown type
                  ]

  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)

-- | Phantom typed 'Query' to get 'Column' from schema name and table name.
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

-- | 'Relation' to query primary key length from schema name and table name.
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'  -- 'p': primary key constraint type

  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)")

-- | Phantom typed 'Query' to get primary key length from schema name and table name.
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

-- | One column which is nth column of composite primary key.
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)

-- | Make composite primary key relation from primary key length.
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] ]

-- | 'Relation' to query primary key name from schema name and table name.
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'  -- 'p': primary key constraint type

  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')

-- | Phantom typed 'Query' to get primary key name from schema name and table name.
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