{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Database.Beam.AutoMigrate.Postgres
  ( getSchema,
  )
where

import Control.Monad.State
import Data.Bits (shiftR, (.&.))
import Data.ByteString (ByteString)
import Data.Foldable (asum, foldlM)
import Data.Map (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as S
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Vector as V
import Database.Beam.AutoMigrate.Types
import Database.Beam.Backend.SQL hiding (tableName)
import qualified Database.Beam.Backend.SQL.AST as AST
import qualified Database.PostgreSQL.Simple as Pg
import Database.PostgreSQL.Simple.FromField (FromField (..), fromField, returnError)
import Database.PostgreSQL.Simple.FromRow (FromRow (..), field)
import qualified Database.PostgreSQL.Simple.TypeInfo.Static as Pg
import qualified Database.PostgreSQL.Simple.Types as Pg

--
-- Necessary types to make working with the underlying raw SQL a bit more pleasant
--

data SqlRawOtherConstraintType
  = SQL_raw_pk
  | SQL_raw_unique
  deriving (Int -> SqlRawOtherConstraintType -> ShowS
[SqlRawOtherConstraintType] -> ShowS
SqlRawOtherConstraintType -> String
(Int -> SqlRawOtherConstraintType -> ShowS)
-> (SqlRawOtherConstraintType -> String)
-> ([SqlRawOtherConstraintType] -> ShowS)
-> Show SqlRawOtherConstraintType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SqlRawOtherConstraintType] -> ShowS
$cshowList :: [SqlRawOtherConstraintType] -> ShowS
show :: SqlRawOtherConstraintType -> String
$cshow :: SqlRawOtherConstraintType -> String
showsPrec :: Int -> SqlRawOtherConstraintType -> ShowS
$cshowsPrec :: Int -> SqlRawOtherConstraintType -> ShowS
Show, SqlRawOtherConstraintType -> SqlRawOtherConstraintType -> Bool
(SqlRawOtherConstraintType -> SqlRawOtherConstraintType -> Bool)
-> (SqlRawOtherConstraintType -> SqlRawOtherConstraintType -> Bool)
-> Eq SqlRawOtherConstraintType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SqlRawOtherConstraintType -> SqlRawOtherConstraintType -> Bool
$c/= :: SqlRawOtherConstraintType -> SqlRawOtherConstraintType -> Bool
== :: SqlRawOtherConstraintType -> SqlRawOtherConstraintType -> Bool
$c== :: SqlRawOtherConstraintType -> SqlRawOtherConstraintType -> Bool
Eq)

data SqlOtherConstraint = SqlOtherConstraint
  { SqlOtherConstraint -> Text
sqlCon_name :: Text,
    SqlOtherConstraint -> SqlRawOtherConstraintType
sqlCon_constraint_type :: SqlRawOtherConstraintType,
    SqlOtherConstraint -> TableName
sqlCon_table :: TableName,
    SqlOtherConstraint -> Vector ColumnName
sqlCon_fk_colums :: V.Vector ColumnName
  }
  deriving (Int -> SqlOtherConstraint -> ShowS
[SqlOtherConstraint] -> ShowS
SqlOtherConstraint -> String
(Int -> SqlOtherConstraint -> ShowS)
-> (SqlOtherConstraint -> String)
-> ([SqlOtherConstraint] -> ShowS)
-> Show SqlOtherConstraint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SqlOtherConstraint] -> ShowS
$cshowList :: [SqlOtherConstraint] -> ShowS
show :: SqlOtherConstraint -> String
$cshow :: SqlOtherConstraint -> String
showsPrec :: Int -> SqlOtherConstraint -> ShowS
$cshowsPrec :: Int -> SqlOtherConstraint -> ShowS
Show, SqlOtherConstraint -> SqlOtherConstraint -> Bool
(SqlOtherConstraint -> SqlOtherConstraint -> Bool)
-> (SqlOtherConstraint -> SqlOtherConstraint -> Bool)
-> Eq SqlOtherConstraint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SqlOtherConstraint -> SqlOtherConstraint -> Bool
$c/= :: SqlOtherConstraint -> SqlOtherConstraint -> Bool
== :: SqlOtherConstraint -> SqlOtherConstraint -> Bool
$c== :: SqlOtherConstraint -> SqlOtherConstraint -> Bool
Eq)

instance Pg.FromRow SqlOtherConstraint where
  fromRow :: RowParser SqlOtherConstraint
fromRow =
    Text
-> SqlRawOtherConstraintType
-> TableName
-> Vector ColumnName
-> SqlOtherConstraint
SqlOtherConstraint (Text
 -> SqlRawOtherConstraintType
 -> TableName
 -> Vector ColumnName
 -> SqlOtherConstraint)
-> RowParser Text
-> RowParser
     (SqlRawOtherConstraintType
      -> TableName -> Vector ColumnName -> SqlOtherConstraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser Text
forall a. FromField a => RowParser a
field
      RowParser
  (SqlRawOtherConstraintType
   -> TableName -> Vector ColumnName -> SqlOtherConstraint)
-> RowParser SqlRawOtherConstraintType
-> RowParser (TableName -> Vector ColumnName -> SqlOtherConstraint)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser SqlRawOtherConstraintType
forall a. FromField a => RowParser a
field
      RowParser (TableName -> Vector ColumnName -> SqlOtherConstraint)
-> RowParser TableName
-> RowParser (Vector ColumnName -> SqlOtherConstraint)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> TableName) -> RowParser Text -> RowParser TableName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> TableName
TableName RowParser Text
forall a. FromField a => RowParser a
field
      RowParser (Vector ColumnName -> SqlOtherConstraint)
-> RowParser (Vector ColumnName) -> RowParser SqlOtherConstraint
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Vector Text -> Vector ColumnName)
-> RowParser (Vector Text) -> RowParser (Vector ColumnName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> ColumnName) -> Vector Text -> Vector ColumnName
forall a b. (a -> b) -> Vector a -> Vector b
V.map Text -> ColumnName
ColumnName) RowParser (Vector Text)
forall a. FromField a => RowParser a
field

data SqlForeignConstraint = SqlForeignConstraint
  { SqlForeignConstraint -> TableName
sqlFk_foreign_table :: TableName,
    SqlForeignConstraint -> TableName
sqlFk_primary_table :: TableName,
    -- | The columns in the /foreign/ table.
    SqlForeignConstraint -> Vector ColumnName
sqlFk_fk_columns :: V.Vector ColumnName,
    -- | The columns in the /current/ table.
    SqlForeignConstraint -> Vector ColumnName
sqlFk_pk_columns :: V.Vector ColumnName,
    SqlForeignConstraint -> Text
sqlFk_name :: Text
  }
  deriving (Int -> SqlForeignConstraint -> ShowS
[SqlForeignConstraint] -> ShowS
SqlForeignConstraint -> String
(Int -> SqlForeignConstraint -> ShowS)
-> (SqlForeignConstraint -> String)
-> ([SqlForeignConstraint] -> ShowS)
-> Show SqlForeignConstraint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SqlForeignConstraint] -> ShowS
$cshowList :: [SqlForeignConstraint] -> ShowS
show :: SqlForeignConstraint -> String
$cshow :: SqlForeignConstraint -> String
showsPrec :: Int -> SqlForeignConstraint -> ShowS
$cshowsPrec :: Int -> SqlForeignConstraint -> ShowS
Show, SqlForeignConstraint -> SqlForeignConstraint -> Bool
(SqlForeignConstraint -> SqlForeignConstraint -> Bool)
-> (SqlForeignConstraint -> SqlForeignConstraint -> Bool)
-> Eq SqlForeignConstraint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SqlForeignConstraint -> SqlForeignConstraint -> Bool
$c/= :: SqlForeignConstraint -> SqlForeignConstraint -> Bool
== :: SqlForeignConstraint -> SqlForeignConstraint -> Bool
$c== :: SqlForeignConstraint -> SqlForeignConstraint -> Bool
Eq)

instance Pg.FromRow SqlForeignConstraint where
  fromRow :: RowParser SqlForeignConstraint
fromRow =
    TableName
-> TableName
-> Vector ColumnName
-> Vector ColumnName
-> Text
-> SqlForeignConstraint
SqlForeignConstraint (TableName
 -> TableName
 -> Vector ColumnName
 -> Vector ColumnName
 -> Text
 -> SqlForeignConstraint)
-> RowParser TableName
-> RowParser
     (TableName
      -> Vector ColumnName
      -> Vector ColumnName
      -> Text
      -> SqlForeignConstraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> TableName) -> RowParser Text -> RowParser TableName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> TableName
TableName RowParser Text
forall a. FromField a => RowParser a
field
      RowParser
  (TableName
   -> Vector ColumnName
   -> Vector ColumnName
   -> Text
   -> SqlForeignConstraint)
-> RowParser TableName
-> RowParser
     (Vector ColumnName
      -> Vector ColumnName -> Text -> SqlForeignConstraint)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> TableName) -> RowParser Text -> RowParser TableName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> TableName
TableName RowParser Text
forall a. FromField a => RowParser a
field
      RowParser
  (Vector ColumnName
   -> Vector ColumnName -> Text -> SqlForeignConstraint)
-> RowParser (Vector ColumnName)
-> RowParser (Vector ColumnName -> Text -> SqlForeignConstraint)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Vector Text -> Vector ColumnName)
-> RowParser (Vector Text) -> RowParser (Vector ColumnName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> ColumnName) -> Vector Text -> Vector ColumnName
forall a b. (a -> b) -> Vector a -> Vector b
V.map Text -> ColumnName
ColumnName) RowParser (Vector Text)
forall a. FromField a => RowParser a
field
      RowParser (Vector ColumnName -> Text -> SqlForeignConstraint)
-> RowParser (Vector ColumnName)
-> RowParser (Text -> SqlForeignConstraint)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Vector Text -> Vector ColumnName)
-> RowParser (Vector Text) -> RowParser (Vector ColumnName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> ColumnName) -> Vector Text -> Vector ColumnName
forall a b. (a -> b) -> Vector a -> Vector b
V.map Text -> ColumnName
ColumnName) RowParser (Vector Text)
forall a. FromField a => RowParser a
field
      RowParser (Text -> SqlForeignConstraint)
-> RowParser Text -> RowParser SqlForeignConstraint
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser Text
forall a. FromField a => RowParser a
field

instance FromField TableName where
  fromField :: FieldParser TableName
fromField Field
f Maybe ByteString
dat = Text -> TableName
TableName (Text -> TableName) -> Conversion Text -> Conversion TableName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldParser Text
forall a. FromField a => FieldParser a
fromField Field
f Maybe ByteString
dat

instance FromField ColumnName where
  fromField :: FieldParser ColumnName
fromField Field
f Maybe ByteString
dat = Text -> ColumnName
ColumnName (Text -> ColumnName) -> Conversion Text -> Conversion ColumnName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldParser Text
forall a. FromField a => FieldParser a
fromField Field
f Maybe ByteString
dat

instance FromField SqlRawOtherConstraintType where
  fromField :: FieldParser SqlRawOtherConstraintType
fromField Field
f Maybe ByteString
dat = do
    String
t :: String <- FieldParser String
forall a. FromField a => FieldParser a
fromField Field
f Maybe ByteString
dat
    case String
t of
      String
"p" -> SqlRawOtherConstraintType -> Conversion SqlRawOtherConstraintType
forall (f :: * -> *) a. Applicative f => a -> f a
pure SqlRawOtherConstraintType
SQL_raw_pk
      String
"u" -> SqlRawOtherConstraintType -> Conversion SqlRawOtherConstraintType
forall (f :: * -> *) a. Applicative f => a -> f a
pure SqlRawOtherConstraintType
SQL_raw_unique
      String
_ -> (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion SqlRawOtherConstraintType
forall a err.
(Typeable a, Exception err) =>
(String -> Maybe Oid -> String -> String -> String -> err)
-> Field -> String -> Conversion a
returnError String -> Maybe Oid -> String -> String -> String -> ResultError
Pg.ConversionFailed Field
f String
t

--
-- Postgres queries to extract the schema out of the DB
--

-- | A SQL query to select all user's queries, skipping any beam-related tables (i.e. leftovers from
-- beam-migrate, for example).
userTablesQ :: Pg.Query
userTablesQ :: Query
userTablesQ =
  String -> Query
forall a. IsString a => String -> a
fromString (String -> Query) -> String -> Query
forall a b. (a -> b) -> a -> b
$
    [String] -> String
unlines
      [ String
"SELECT cl.oid, relname FROM pg_catalog.pg_class \"cl\" join pg_catalog.pg_namespace \"ns\" ",
        String
"on (ns.oid = relnamespace) where nspname = any (current_schemas(false)) and relkind='r' ",
        String
"and relname NOT LIKE 'beam_%'"
      ]

-- | Get information about default values for /all/ tables.
defaultsQ :: Pg.Query
defaultsQ :: Query
defaultsQ =
  String -> Query
forall a. IsString a => String -> a
fromString (String -> Query) -> String -> Query
forall a b. (a -> b) -> a -> b
$
    [String] -> String
unlines
      [ String
"SELECT col.table_name::text, col.column_name::text, col.column_default::text, col.data_type::text ",
        String
"FROM information_schema.columns col ",
        String
"WHERE col.column_default IS NOT NULL ",
        String
"AND col.table_schema NOT IN('information_schema', 'pg_catalog') ",
        String
"ORDER BY col.table_name"
      ]

-- | Get information about columns for this table. Due to the fact this is a query executed for /each/
-- table, is important this is as light as possible to keep the performance decent.
tableColumnsQ :: Pg.Query
tableColumnsQ :: Query
tableColumnsQ =
  String -> Query
forall a. IsString a => String -> a
fromString (String -> Query) -> String -> Query
forall a b. (a -> b) -> a -> b
$
    [String] -> String
unlines
      [ String
"SELECT attname, atttypid, atttypmod, attndims, attnotnull, pg_catalog.format_type(atttypid, atttypmod) ",
        String
"FROM pg_catalog.pg_attribute att ",
        String
"WHERE att.attrelid=? AND att.attnum>0 AND att.attisdropped='f' "
      ]

-- | Get the enumeration data for all enum types in the database.
enumerationsQ :: Pg.Query
enumerationsQ :: Query
enumerationsQ =
  String -> Query
forall a. IsString a => String -> a
fromString (String -> Query) -> String -> Query
forall a b. (a -> b) -> a -> b
$
    [String] -> String
unlines
      [ String
"SELECT t.typname, t.oid, array_agg(e.enumlabel ORDER BY e.enumsortorder)",
        String
"FROM pg_enum e JOIN pg_type t ON t.oid = e.enumtypid",
        String
"GROUP BY t.typname, t.oid"
      ]

-- | Get the sequence data for all sequence types in the database.
sequencesQ :: Pg.Query
sequencesQ :: Query
sequencesQ = String -> Query
forall a. IsString a => String -> a
fromString String
"SELECT c.relname FROM pg_class c WHERE c.relkind = 'S'"

-- | Return all foreign key constraints for /all/ 'Table's.
foreignKeysQ :: Pg.Query
foreignKeysQ :: Query
foreignKeysQ =
  String -> Query
forall a. IsString a => String -> a
fromString (String -> Query) -> String -> Query
forall a b. (a -> b) -> a -> b
$
    [String] -> String
unlines
      [ String
"SELECT kcu.table_name::text as foreign_table,",
        String
"       rel_kcu.table_name::text as primary_table,",
        String
"       array_agg(kcu.column_name::text ORDER BY kcu.position_in_unique_constraint)::text[] as fk_columns,",
        String
"       array_agg(rel_kcu.column_name::text ORDER BY rel_kcu.ordinal_position)::text[] as pk_columns,",
        String
"       kcu.constraint_name as cname",
        String
"FROM information_schema.table_constraints tco",
        String
"JOIN information_schema.key_column_usage kcu",
        String
"          on tco.constraint_schema = kcu.constraint_schema",
        String
"          and tco.constraint_name = kcu.constraint_name",
        String
"JOIN information_schema.referential_constraints rco",
        String
"          on tco.constraint_schema = rco.constraint_schema",
        String
"          and tco.constraint_name = rco.constraint_name",
        String
"JOIN information_schema.key_column_usage rel_kcu",
        String
"          on rco.unique_constraint_schema = rel_kcu.constraint_schema",
        String
"          and rco.unique_constraint_name = rel_kcu.constraint_name",
        String
"          and kcu.ordinal_position = rel_kcu.ordinal_position",
        String
"GROUP BY foreign_table, primary_table, cname"
      ]

-- | Return /all other constraints that are not FKs/ (i.e. 'PRIMARY KEY', 'UNIQUE', etc) for all the tables.
otherConstraintsQ :: Pg.Query
otherConstraintsQ :: Query
otherConstraintsQ =
  String -> Query
forall a. IsString a => String -> a
fromString (String -> Query) -> String -> Query
forall a b. (a -> b) -> a -> b
$
    [String] -> String
unlines
      [ String
"SELECT c.conname                                AS constraint_name,",
        String
"  c.contype                                     AS constraint_type,",
        String
"  tbl.relname                                   AS \"table\",",
        String
"  ARRAY_AGG(col.attname ORDER BY u.attposition) AS columns",
        String
"FROM pg_constraint c",
        String
"     JOIN LATERAL UNNEST(c.conkey) WITH ORDINALITY AS u(attnum, attposition) ON TRUE",
        String
"     JOIN pg_class tbl ON tbl.oid = c.conrelid",
        String
"     JOIN pg_namespace sch ON sch.oid = tbl.relnamespace",
        String
"     JOIN pg_attribute col ON (col.attrelid = tbl.oid AND col.attnum = u.attnum)",
        String
"WHERE c.contype = 'u' OR c.contype = 'p'",
        String
"GROUP BY constraint_name, constraint_type, \"table\"",
        String
"ORDER BY c.contype"
      ]

-- | Return all \"action types\" for /all/ the constraints.
referenceActionsQ :: Pg.Query
referenceActionsQ :: Query
referenceActionsQ =
  String -> Query
forall a. IsString a => String -> a
fromString (String -> Query) -> String -> Query
forall a b. (a -> b) -> a -> b
$
    [String] -> String
unlines
      [ String
"SELECT c.conname, c. confdeltype, c.confupdtype FROM ",
        String
"(SELECT r.conrelid, r.confrelid, unnest(r.conkey) AS conkey, unnest(r.confkey) AS confkey, r.conname, r.confupdtype, r.confdeltype ",
        String
"FROM pg_catalog.pg_constraint r WHERE r.contype = 'f') AS c ",
        String
"INNER JOIN pg_attribute a_parent ON a_parent.attnum = c.confkey AND a_parent.attrelid = c.confrelid ",
        String
"INNER JOIN pg_class cl_parent ON cl_parent.oid = c.confrelid ",
        String
"INNER JOIN pg_namespace sch_parent ON sch_parent.oid = cl_parent.relnamespace ",
        String
"INNER JOIN pg_attribute a_child ON a_child.attnum = c.conkey AND a_child.attrelid = c.conrelid ",
        String
"INNER JOIN pg_class cl_child ON cl_child.oid = c.conrelid ",
        String
"INNER JOIN pg_namespace sch_child ON sch_child.oid = cl_child.relnamespace ",
        String
"WHERE sch_child.nspname = current_schema() ORDER BY c.conname "
      ]

-- | Return the names and OIDs of all user defined types in the public namespace
--
-- This lets us work with types that come from extensions, regardless of when the extension is added.
-- Without this, the OIDs of these types could shift underneath us.
extensionTypeNamesQ :: Pg.Query
extensionTypeNamesQ :: Query
extensionTypeNamesQ =
  String -> Query
forall a. IsString a => String -> a
fromString (String -> Query) -> String -> Query
forall a b. (a -> b) -> a -> b
$
    [String] -> String
unlines
      [ String
"SELECT ty.oid, ty.typname ",
        String
"FROM pg_type ty ",
        String
"INNER JOIN pg_namespace ns ON ty.typnamespace = ns.oid ",
        String
"WHERE ns.nspname = 'public' AND ty.typcategory = 'U' "
      ]

-- | Connects to a running PostgreSQL database and extract the relevant 'Schema' out of it.
getSchema :: Pg.Connection -> IO Schema
getSchema :: Connection -> IO Schema
getSchema Connection
conn = do
  AllTableConstraints
allTableConstraints <- Connection -> IO AllTableConstraints
getAllConstraints Connection
conn
  AllDefaults
allDefaults <- Connection -> IO AllDefaults
getAllDefaults Connection
conn
  Map Oid ExtensionTypeName
extensionTypeData <- Connection
-> Query
-> Map Oid ExtensionTypeName
-> (Map Oid ExtensionTypeName
    -> (Oid, Text) -> IO (Map Oid ExtensionTypeName))
-> IO (Map Oid ExtensionTypeName)
forall r a.
FromRow r =>
Connection -> Query -> a -> (a -> r -> IO a) -> IO a
Pg.fold_ Connection
conn Query
extensionTypeNamesQ Map Oid ExtensionTypeName
forall a. Monoid a => a
mempty Map Oid ExtensionTypeName
-> (Oid, Text) -> IO (Map Oid ExtensionTypeName)
getExtension
  Map Oid (EnumerationName, Enumeration)
enumerationData <- Connection
-> Query
-> Map Oid (EnumerationName, Enumeration)
-> (Map Oid (EnumerationName, Enumeration)
    -> (Text, Oid, Vector Text)
    -> IO (Map Oid (EnumerationName, Enumeration)))
-> IO (Map Oid (EnumerationName, Enumeration))
forall r a.
FromRow r =>
Connection -> Query -> a -> (a -> r -> IO a) -> IO a
Pg.fold_ Connection
conn Query
enumerationsQ Map Oid (EnumerationName, Enumeration)
forall a. Monoid a => a
mempty Map Oid (EnumerationName, Enumeration)
-> (Text, Oid, Vector Text)
-> IO (Map Oid (EnumerationName, Enumeration))
getEnumeration
  Sequences
sequences <- Connection
-> Query
-> Sequences
-> (Sequences -> Only Text -> IO Sequences)
-> IO Sequences
forall r a.
FromRow r =>
Connection -> Query -> a -> (a -> r -> IO a) -> IO a
Pg.fold_ Connection
conn Query
sequencesQ Sequences
forall a. Monoid a => a
mempty Sequences -> Only Text -> IO Sequences
getSequence
  Tables
tables <-
    Connection
-> Query
-> Tables
-> (Tables -> (Oid, Text) -> IO Tables)
-> IO Tables
forall r a.
FromRow r =>
Connection -> Query -> a -> (a -> r -> IO a) -> IO a
Pg.fold_ Connection
conn Query
userTablesQ Tables
forall a. Monoid a => a
mempty (AllDefaults
-> Map Oid ExtensionTypeName
-> Map Oid (EnumerationName, Enumeration)
-> AllTableConstraints
-> Tables
-> (Oid, Text)
-> IO Tables
getTable AllDefaults
allDefaults Map Oid ExtensionTypeName
extensionTypeData Map Oid (EnumerationName, Enumeration)
enumerationData AllTableConstraints
allTableConstraints)
  Schema -> IO Schema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> IO Schema) -> Schema -> IO Schema
forall a b. (a -> b) -> a -> b
$ Tables -> Enumerations -> Sequences -> Schema
Schema Tables
tables ([(EnumerationName, Enumeration)] -> Enumerations
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(EnumerationName, Enumeration)] -> Enumerations)
-> [(EnumerationName, Enumeration)] -> Enumerations
forall a b. (a -> b) -> a -> b
$ Map Oid (EnumerationName, Enumeration)
-> [(EnumerationName, Enumeration)]
forall k a. Map k a -> [a]
M.elems Map Oid (EnumerationName, Enumeration)
enumerationData) Sequences
sequences
  where
    getExtension ::
     Map Pg.Oid ExtensionTypeName ->
     (Pg.Oid, Text) ->
     IO (Map Pg.Oid ExtensionTypeName)
    getExtension :: Map Oid ExtensionTypeName
-> (Oid, Text) -> IO (Map Oid ExtensionTypeName)
getExtension Map Oid ExtensionTypeName
allExtensions (Oid
oid, Text
name) =
      Map Oid ExtensionTypeName -> IO (Map Oid ExtensionTypeName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Oid ExtensionTypeName -> IO (Map Oid ExtensionTypeName))
-> Map Oid ExtensionTypeName -> IO (Map Oid ExtensionTypeName)
forall a b. (a -> b) -> a -> b
$ Oid
-> ExtensionTypeName
-> Map Oid ExtensionTypeName
-> Map Oid ExtensionTypeName
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Oid
oid (Text -> ExtensionTypeName
ExtensionTypeName Text
name) Map Oid ExtensionTypeName
allExtensions

    getEnumeration ::
      Map Pg.Oid (EnumerationName, Enumeration) ->
      (Text, Pg.Oid, V.Vector Text) ->
      IO (Map Pg.Oid (EnumerationName, Enumeration))
    getEnumeration :: Map Oid (EnumerationName, Enumeration)
-> (Text, Oid, Vector Text)
-> IO (Map Oid (EnumerationName, Enumeration))
getEnumeration Map Oid (EnumerationName, Enumeration)
allEnums (Text
enumName, Oid
oid, Vector Text -> [Text]
forall a. Vector a -> [a]
V.toList -> [Text]
vals) =
      Map Oid (EnumerationName, Enumeration)
-> IO (Map Oid (EnumerationName, Enumeration))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Oid (EnumerationName, Enumeration)
 -> IO (Map Oid (EnumerationName, Enumeration)))
-> Map Oid (EnumerationName, Enumeration)
-> IO (Map Oid (EnumerationName, Enumeration))
forall a b. (a -> b) -> a -> b
$ Oid
-> (EnumerationName, Enumeration)
-> Map Oid (EnumerationName, Enumeration)
-> Map Oid (EnumerationName, Enumeration)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Oid
oid (Text -> EnumerationName
EnumerationName Text
enumName, [Text] -> Enumeration
Enumeration [Text]
vals) Map Oid (EnumerationName, Enumeration)
allEnums

    getSequence ::
      Sequences ->
      Pg.Only Text ->
      IO Sequences
    getSequence :: Sequences -> Only Text -> IO Sequences
getSequence Sequences
allSeqs (Pg.Only Text
seqName) =
      case Text -> Text -> [Text]
T.splitOn Text
"___" Text
seqName of
        [Text
tName, Text
cName, Text
"seq"] ->
          Sequences -> IO Sequences
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sequences -> IO Sequences) -> Sequences -> IO Sequences
forall a b. (a -> b) -> a -> b
$ SequenceName -> Sequence -> Sequences -> Sequences
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Text -> SequenceName
SequenceName Text
seqName) (TableName -> ColumnName -> Sequence
Sequence (Text -> TableName
TableName Text
tName) (Text -> ColumnName
ColumnName Text
cName)) Sequences
allSeqs
        [Text]
_ -> Sequences -> IO Sequences
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sequences
allSeqs

    getTable ::
      AllDefaults ->
      Map Pg.Oid ExtensionTypeName ->
      Map Pg.Oid (EnumerationName, Enumeration) ->
      AllTableConstraints ->
      Tables ->
      (Pg.Oid, Text) ->
      IO Tables
    getTable :: AllDefaults
-> Map Oid ExtensionTypeName
-> Map Oid (EnumerationName, Enumeration)
-> AllTableConstraints
-> Tables
-> (Oid, Text)
-> IO Tables
getTable AllDefaults
allDefaults Map Oid ExtensionTypeName
extensionTypeData Map Oid (EnumerationName, Enumeration)
enumData AllTableConstraints
allTableConstraints Tables
allTables (Oid
oid, Text -> TableName
TableName -> TableName
tName) = do
      [(ByteString, Oid, Int, Int, Bool, ByteString)]
pgColumns <- Connection
-> Query
-> Only Oid
-> IO [(ByteString, Oid, Int, Int, Bool, ByteString)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
Pg.query Connection
conn Query
tableColumnsQ (Oid -> Only Oid
forall a. a -> Only a
Pg.Only Oid
oid)
      Table
newTable <-
        Set TableConstraint -> Columns -> Table
Table (Set TableConstraint
-> Maybe (Set TableConstraint) -> Set TableConstraint
forall a. a -> Maybe a -> a
fromMaybe Set TableConstraint
noTableConstraints (TableName -> AllTableConstraints -> Maybe (Set TableConstraint)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TableName
tName AllTableConstraints
allTableConstraints))
          (Columns -> Table) -> IO Columns -> IO Table
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Columns
 -> (ByteString, Oid, Int, Int, Bool, ByteString) -> IO Columns)
-> Columns
-> [(ByteString, Oid, Int, Int, Bool, ByteString)]
-> IO Columns
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (TableName
-> Map Oid ExtensionTypeName
-> Map Oid (EnumerationName, Enumeration)
-> AllDefaults
-> Columns
-> (ByteString, Oid, Int, Int, Bool, ByteString)
-> IO Columns
getColumns TableName
tName Map Oid ExtensionTypeName
extensionTypeData Map Oid (EnumerationName, Enumeration)
enumData AllDefaults
allDefaults) Columns
forall a. Monoid a => a
mempty [(ByteString, Oid, Int, Int, Bool, ByteString)]
pgColumns
      Tables -> IO Tables
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tables -> IO Tables) -> Tables -> IO Tables
forall a b. (a -> b) -> a -> b
$ TableName -> Table -> Tables -> Tables
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TableName
tName Table
newTable Tables
allTables

    getColumns ::
      TableName ->
      Map Pg.Oid ExtensionTypeName ->
      Map Pg.Oid (EnumerationName, Enumeration) ->
      AllDefaults ->
      Columns ->
      (ByteString, Pg.Oid, Int, Int, Bool, ByteString) ->
      IO Columns
    getColumns :: TableName
-> Map Oid ExtensionTypeName
-> Map Oid (EnumerationName, Enumeration)
-> AllDefaults
-> Columns
-> (ByteString, Oid, Int, Int, Bool, ByteString)
-> IO Columns
getColumns TableName
tName Map Oid ExtensionTypeName
extensionTypeData Map Oid (EnumerationName, Enumeration)
enumData AllDefaults
defaultData Columns
c (ByteString
attname, Oid
atttypid, Int
atttypmod, Int
attndims, Bool
attnotnull, ByteString
format_type) = do
      -- /NOTA BENE(adn)/: The atttypmod - 4 was originally taken from 'beam-migrate'
      -- (see: https://github.com/tathougies/beam/blob/d87120b58373df53f075d92ce12037a98ca709ab/beam-postgres/Database/Beam/Postgres/Migrate.hs#L343)
      -- but there are cases where this is not correct, for example in the case of bitstrings.
      -- See for example: https://stackoverflow.com/questions/52376045/why-does-atttypmod-differ-from-character-maximum-length
      let mbPrecision :: Maybe Int
mbPrecision =
            if
                | Int
atttypmod Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1 -> Maybe Int
forall a. Maybe a
Nothing
                | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.bit Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
atttypid -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
atttypmod
                | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.varbit Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
atttypid -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
atttypmod
                | Bool
otherwise -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
atttypmod Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4)

      let columnName :: ColumnName
columnName = Text -> ColumnName
ColumnName (ByteString -> Text
TE.decodeUtf8 ByteString
attname)

      let mbDefault :: Maybe ColumnConstraint
mbDefault = do
            Defaults
x <- TableName -> AllDefaults -> Maybe Defaults
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TableName
tName AllDefaults
defaultData
            ColumnName -> Defaults -> Maybe ColumnConstraint
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ColumnName
columnName Defaults
x

      case [Maybe ColumnType] -> Maybe ColumnType
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ Oid -> Maybe ColumnConstraint -> Maybe ColumnType
pgSerialTyColumnType Oid
atttypid Maybe ColumnConstraint
mbDefault,
          Map Oid ExtensionTypeName -> Oid -> Maybe Int -> Maybe ColumnType
pgTypeToColumnType Map Oid ExtensionTypeName
extensionTypeData Oid
atttypid Maybe Int
mbPrecision,
          Map Oid (EnumerationName, Enumeration) -> Oid -> Maybe ColumnType
pgEnumTypeToColumnType Map Oid (EnumerationName, Enumeration)
enumData Oid
atttypid,
          Map Oid ExtensionTypeName
-> Oid -> Maybe Int -> Int -> Maybe ColumnType
pgArrayTypeToColumnType Map Oid ExtensionTypeName
extensionTypeData Oid
atttypid Maybe Int
mbPrecision Int
attndims
        ] of
        Just ColumnType
cType -> do
          let nullConstraint :: Set ColumnConstraint
nullConstraint = if Bool
attnotnull then [ColumnConstraint] -> Set ColumnConstraint
forall a. Ord a => [a] -> Set a
S.fromList [ColumnConstraint
NotNull] else Set ColumnConstraint
forall a. Monoid a => a
mempty
          let inferredConstraints :: Set ColumnConstraint
inferredConstraints = Set ColumnConstraint
nullConstraint Set ColumnConstraint
-> Set ColumnConstraint -> Set ColumnConstraint
forall a. Semigroup a => a -> a -> a
<> Set ColumnConstraint
-> Maybe (Set ColumnConstraint) -> Set ColumnConstraint
forall a. a -> Maybe a -> a
fromMaybe Set ColumnConstraint
forall a. Monoid a => a
mempty (ColumnConstraint -> Set ColumnConstraint
forall a. a -> Set a
S.singleton (ColumnConstraint -> Set ColumnConstraint)
-> Maybe ColumnConstraint -> Maybe (Set ColumnConstraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ColumnConstraint
mbDefault)
          let newColumn :: Column
newColumn = ColumnType -> Set ColumnConstraint -> Column
Column ColumnType
cType Set ColumnConstraint
inferredConstraints
          Columns -> IO Columns
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Columns -> IO Columns) -> Columns -> IO Columns
forall a b. (a -> b) -> a -> b
$ ColumnName -> Column -> Columns -> Columns
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ColumnName
columnName Column
newColumn Columns
c
        Maybe ColumnType
Nothing ->
          String -> IO Columns
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Columns) -> String -> IO Columns
forall a b. (a -> b) -> a -> b
$
            String
"Couldn't convert pgType "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
format_type
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" of field "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
attname
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" into a valid ColumnType."

--
-- Postgres type mapping
--

pgEnumTypeToColumnType ::
  Map Pg.Oid (EnumerationName, Enumeration) ->
  Pg.Oid ->
  Maybe ColumnType
pgEnumTypeToColumnType :: Map Oid (EnumerationName, Enumeration) -> Oid -> Maybe ColumnType
pgEnumTypeToColumnType Map Oid (EnumerationName, Enumeration)
enumData Oid
oid =
  (\(EnumerationName
n, Enumeration
_) -> PgDataType -> ColumnType
PgSpecificType (EnumerationName -> PgDataType
PgEnumeration EnumerationName
n)) ((EnumerationName, Enumeration) -> ColumnType)
-> Maybe (EnumerationName, Enumeration) -> Maybe ColumnType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Oid
-> Map Oid (EnumerationName, Enumeration)
-> Maybe (EnumerationName, Enumeration)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Oid
oid Map Oid (EnumerationName, Enumeration)
enumData

pgSerialTyColumnType ::
  Pg.Oid ->
  Maybe ColumnConstraint ->
  Maybe ColumnType
pgSerialTyColumnType :: Oid -> Maybe ColumnConstraint -> Maybe ColumnType
pgSerialTyColumnType Oid
oid (Just (Default Text
d)) = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ (TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.int4 Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid Bool -> Bool -> Bool
&& Text
"nextval" Text -> Text -> Bool
`T.isInfixOf` Text
d Bool -> Bool -> Bool
&& Text
"seq" Text -> Text -> Bool
`T.isInfixOf` Text
d)
  ColumnType -> Maybe ColumnType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ColumnType -> Maybe ColumnType) -> ColumnType -> Maybe ColumnType
forall a b. (a -> b) -> a -> b
$ DataType -> ColumnType
SqlStdType DataType
forall dataType. IsSql92DataTypeSyntax dataType => dataType
intType
pgSerialTyColumnType Oid
_ Maybe ColumnConstraint
_ = Maybe ColumnType
forall a. Maybe a
Nothing

-- | Tries to convert from a Postgres' 'Oid' into 'ColumnType'.
-- Mostly taken from [beam-migrate](Database.Beam.Postgres.Migrate).
pgTypeToColumnType :: Map Pg.Oid ExtensionTypeName -> Pg.Oid -> Maybe Int -> Maybe ColumnType
pgTypeToColumnType :: Map Oid ExtensionTypeName -> Oid -> Maybe Int -> Maybe ColumnType
pgTypeToColumnType Map Oid ExtensionTypeName
extensionTypeData Oid
oid Maybe Int
width
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.int2 Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType DataType
forall dataType. IsSql92DataTypeSyntax dataType => dataType
smallIntType)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.int4 Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType DataType
forall dataType. IsSql92DataTypeSyntax dataType => dataType
intType)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.int8 Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType DataType
forall dataType. IsSql2008BigIntDataTypeSyntax dataType => dataType
bigIntType)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.bpchar Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType (DataType -> ColumnType) -> DataType -> ColumnType
forall a b. (a -> b) -> a -> b
$ Maybe Word -> Maybe Text -> DataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Maybe Text -> dataType
charType (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Maybe Int -> Maybe Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
width) Maybe Text
forall a. Maybe a
Nothing)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.varchar Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType (DataType -> ColumnType) -> DataType -> ColumnType
forall a b. (a -> b) -> a -> b
$ Maybe Word -> Maybe Text -> DataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Maybe Text -> dataType
varCharType (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Maybe Int -> Maybe Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
width) Maybe Text
forall a. Maybe a
Nothing)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.bit Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType (DataType -> ColumnType) -> DataType -> ColumnType
forall a b. (a -> b) -> a -> b
$ Maybe Word -> DataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> dataType
bitType (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Maybe Int -> Maybe Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
width))
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.varbit Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType (DataType -> ColumnType) -> DataType -> ColumnType
forall a b. (a -> b) -> a -> b
$ Maybe Word -> DataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> dataType
varBitType (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Maybe Int -> Maybe Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
width))
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.numeric Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    let decimals :: Int
decimals = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
width Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xFFFF
        prec :: Int
prec = (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
width Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xFFFF
     in case (Int
prec, Int
decimals) of
          (Int
0, Int
0) -> ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType (DataType -> ColumnType) -> DataType -> ColumnType
forall a b. (a -> b) -> a -> b
$ Maybe (Word, Maybe Word) -> DataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe (Word, Maybe Word) -> dataType
numericType Maybe (Word, Maybe Word)
forall a. Maybe a
Nothing)
          (Int
p, Int
0) -> ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType (DataType -> ColumnType) -> DataType -> ColumnType
forall a b. (a -> b) -> a -> b
$ Maybe (Word, Maybe Word) -> DataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe (Word, Maybe Word) -> dataType
numericType (Maybe (Word, Maybe Word) -> DataType)
-> Maybe (Word, Maybe Word) -> DataType
forall a b. (a -> b) -> a -> b
$ (Word, Maybe Word) -> Maybe (Word, Maybe Word)
forall a. a -> Maybe a
Just (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
p, Maybe Word
forall a. Maybe a
Nothing))
          (Int, Int)
_ -> ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType (DataType -> ColumnType) -> DataType -> ColumnType
forall a b. (a -> b) -> a -> b
$ Maybe (Word, Maybe Word) -> DataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe (Word, Maybe Word) -> dataType
numericType ((Word, Maybe Word) -> Maybe (Word, Maybe Word)
forall a. a -> Maybe a
Just (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
prec, Word -> Maybe Word
forall a. a -> Maybe a
Just (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
decimals))))
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.float4 Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType DataType
forall dataType. IsSql92DataTypeSyntax dataType => dataType
realType)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.float8 Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType DataType
forall dataType. IsSql92DataTypeSyntax dataType => dataType
doubleType)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.date Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType DataType
forall dataType. IsSql92DataTypeSyntax dataType => dataType
dateType)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.text Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType DataType
forall dataType. IsSql99DataTypeSyntax dataType => dataType
characterLargeObjectType)
  -- I am not sure if this is a bug in beam-core, but both 'characterLargeObjectType' and 'binaryLargeObjectType'
  -- get mapped into 'AST.DataTypeCharacterLargeObject', which yields TEXT, whereas we want the latter to
  -- yield bytea.
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.bytea Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType DataType
AST.DataTypeBinaryLargeObject)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.bool Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType DataType
forall dataType. IsSql99DataTypeSyntax dataType => dataType
booleanType)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.time Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType (DataType -> ColumnType) -> DataType -> ColumnType
forall a b. (a -> b) -> a -> b
$ Maybe Word -> Bool -> DataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Bool -> dataType
timeType Maybe Word
forall a. Maybe a
Nothing Bool
False)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.timestamp Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType (DataType -> ColumnType) -> DataType -> ColumnType
forall a b. (a -> b) -> a -> b
$Maybe Word -> Bool -> DataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Bool -> dataType
timestampType Maybe Word
forall a. Maybe a
Nothing Bool
False)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.timestamptz Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (DataType -> ColumnType
SqlStdType (DataType -> ColumnType) -> DataType -> ColumnType
forall a b. (a -> b) -> a -> b
$ Maybe Word -> Bool -> DataType
forall dataType.
IsSql92DataTypeSyntax dataType =>
Maybe Word -> Bool -> dataType
timestampType Maybe Word
forall a. Maybe a
Nothing Bool
True)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.json Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    -- json types
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (PgDataType -> ColumnType
PgSpecificType PgDataType
PgJson)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.jsonb Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (PgDataType -> ColumnType
PgSpecificType PgDataType
PgJsonB)
  -- range types
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.int4range Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (PgDataType -> ColumnType
PgSpecificType PgDataType
PgRangeInt4)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.int8range Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (PgDataType -> ColumnType
PgSpecificType PgDataType
PgRangeInt8)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.numrange Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (PgDataType -> ColumnType
PgSpecificType PgDataType
PgRangeNum)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.tsrange Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (PgDataType -> ColumnType
PgSpecificType PgDataType
PgRangeTs)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.tstzrange Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (PgDataType -> ColumnType
PgSpecificType PgDataType
PgRangeTsTz)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.daterange Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (PgDataType -> ColumnType
PgSpecificType PgDataType
PgRangeDate)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.uuid Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (PgDataType -> ColumnType
PgSpecificType PgDataType
PgUuid)
  | TypeInfo -> Oid
Pg.typoid TypeInfo
Pg.oid Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
oid =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (PgDataType -> ColumnType
PgSpecificType PgDataType
PgOid)
  | Oid -> Map Oid ExtensionTypeName -> Maybe ExtensionTypeName
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Oid
oid Map Oid ExtensionTypeName
extensionTypeData Maybe ExtensionTypeName -> Maybe ExtensionTypeName -> Bool
forall a. Eq a => a -> a -> Bool
== ExtensionTypeName -> Maybe ExtensionTypeName
forall a. a -> Maybe a
Just ExtensionTypeName
"ltree" =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (PgDataType -> ColumnType
PgSpecificType PgDataType
PgLTree)
  | Oid -> Map Oid ExtensionTypeName -> Maybe ExtensionTypeName
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Oid
oid Map Oid ExtensionTypeName
extensionTypeData Maybe ExtensionTypeName -> Maybe ExtensionTypeName -> Bool
forall a. Eq a => a -> a -> Bool
== ExtensionTypeName -> Maybe ExtensionTypeName
forall a. a -> Maybe a
Just ExtensionTypeName
"vector" =
    ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (PgDataType -> ColumnType
PgSpecificType (PgDataType -> ColumnType)
-> (Maybe Natural -> PgDataType) -> Maybe Natural -> ColumnType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Natural -> PgDataType
PgVector (Maybe Natural -> ColumnType) -> Maybe Natural -> ColumnType
forall a b. (a -> b) -> a -> b
$ (Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
4) (Natural -> Natural) -> (Int -> Natural) -> Int -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Maybe Int -> Maybe Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
width)
  | Bool
otherwise = Maybe ColumnType
forall a. Maybe a
Nothing

pgArrayTypeToColumnType :: Map Pg.Oid ExtensionTypeName -> Pg.Oid -> Maybe Int -> Int -> Maybe ColumnType
pgArrayTypeToColumnType :: Map Oid ExtensionTypeName
-> Oid -> Maybe Int -> Int -> Maybe ColumnType
pgArrayTypeToColumnType Map Oid ExtensionTypeName
extensionTypeData Oid
oid Maybe Int
width Int
dims = case Oid -> Maybe TypeInfo
Pg.staticTypeInfo Oid
oid of
  Just (Pg.Array Oid
_ Char
_ Char
_ ByteString
_ TypeInfo
subTypeInfo) -> case Map Oid ExtensionTypeName -> Oid -> Maybe Int -> Maybe ColumnType
pgTypeToColumnType Map Oid ExtensionTypeName
extensionTypeData (TypeInfo -> Oid
Pg.typoid TypeInfo
subTypeInfo) Maybe Int
width of
    Just ColumnType
columnType -> ColumnType -> Maybe ColumnType
forall a. a -> Maybe a
Just (ColumnType -> Maybe ColumnType) -> ColumnType -> Maybe ColumnType
forall a b. (a -> b) -> a -> b
$ ColumnType -> Word -> ColumnType
SqlArrayType ColumnType
columnType (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
dims)
    Maybe ColumnType
_ -> Maybe ColumnType
forall a. Maybe a
Nothing
  Maybe TypeInfo
_ -> Maybe ColumnType
forall a. Maybe a
Nothing

--
-- Constraints discovery
--

type AllTableConstraints = Map TableName (Set TableConstraint)

type AllDefaults = Map TableName Defaults

type Defaults = Map ColumnName ColumnConstraint

-- Get all defaults values for /all/ the columns.
-- FIXME(adn) __IMPORTANT:__ This function currently __always_ attach an explicit type annotation to the
-- default value, by reading its 'date_type' field, to resolve potential ambiguities.
-- The reason for this is that we cannot reliably guarantee a convertion between default values are read
-- by postgres and values we infer on the Schema side (using the 'beam-core' machinery). In theory we
-- wouldn't need to explicitly annotate the types before generating a 'Default' constraint on the 'Schema'
-- side, but this doesn't always work. For example, if we **always** specify a \"::numeric\" annotation for
-- an 'Int', Postgres might yield \"-1::integer\" for non-positive values and simply \"-1\" for all the rest.
-- To complicate the situation /even if/ we explicitly specify the cast
-- (i.e. \"SET DEFAULT '?::character varying'), Postgres will ignore this when reading the default back.
-- What we do here is obviously not optimal, but on the other hand it's not clear to me how to solve this
-- in a meaningful and non-invasive way, for a number of reasons:
--

-- * For example \"beam-migrate"\ seems to resort to be using explicit serialisation for the types, although

--   I couldn't find explicit trace if that applies for defaults explicitly.
--   (cfr. the \"Database.Beam.AutoMigrate.Serialization\" module in \"beam-migrate\").
--

-- * Another big problem is __rounding__: For example if we insert as \"double precision\" the following:

--   Default "'-0.22030397057804563'" , Postgres will round the value and return Default "'-0.220303970578046'".
--   Again, it's not clear to me how to prevent the users from shooting themselves here.
--

-- * Another quirk is with dates: \"beam\" renders a date like \'1864-05-10\' (note the single quotes) but

--   Postgres strip those when reading the default value back.
--

-- * Range types are also tricky to infer. 'beam-core' escapes the range type name when rendering its default

--   value, whereas Postgres annotates each individual field and yield the unquoted identifier. Compare:
--   1. Beam:     \""numrange"(0, 2, '[)')\"
--   2. Postgres: \"numrange((0)::numeric, (2)::numeric, '[)'::text)\"
--
getAllDefaults :: Pg.Connection -> IO AllDefaults
getAllDefaults :: Connection -> IO AllDefaults
getAllDefaults Connection
conn = Connection
-> Query
-> AllDefaults
-> (AllDefaults
    -> (TableName, ColumnName, Text, Text) -> IO AllDefaults)
-> IO AllDefaults
forall r a.
FromRow r =>
Connection -> Query -> a -> (a -> r -> IO a) -> IO a
Pg.fold_ Connection
conn Query
defaultsQ AllDefaults
forall a. Monoid a => a
mempty (\AllDefaults
acc -> AllDefaults -> IO AllDefaults
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AllDefaults -> IO AllDefaults)
-> ((TableName, ColumnName, Text, Text) -> AllDefaults)
-> (TableName, ColumnName, Text, Text)
-> IO AllDefaults
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllDefaults -> (TableName, ColumnName, Text, Text) -> AllDefaults
addDefault AllDefaults
acc)
  where
    addDefault :: AllDefaults -> (TableName, ColumnName, Text, Text) -> AllDefaults
    addDefault :: AllDefaults -> (TableName, ColumnName, Text, Text) -> AllDefaults
addDefault AllDefaults
m (TableName
tName, ColumnName
colName, Text
defValue, Text
dataType) =
      let cleanedDefault :: Text
cleanedDefault = case Text -> Text -> (Text, Text)
T.breakOn Text
"::" Text
defValue of
            (Text
uncasted, Text
defMb)
              | Text -> Bool
T.null Text
defMb ->
                Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Char -> Bool) -> Text -> Text
T.dropAround (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==) Char
'\'') Text
uncasted Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'::" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dataType
            (Text, Text)
_ -> Text
defValue
          entry :: Defaults
entry = ColumnName -> ColumnConstraint -> Defaults
forall k a. k -> a -> Map k a
M.singleton ColumnName
colName (Text -> ColumnConstraint
Default Text
cleanedDefault)
       in (Maybe Defaults -> Maybe Defaults)
-> TableName -> AllDefaults -> AllDefaults
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter
            ( \case
                Maybe Defaults
Nothing -> Defaults -> Maybe Defaults
forall a. a -> Maybe a
Just Defaults
entry
                Just Defaults
ss -> Defaults -> Maybe Defaults
forall a. a -> Maybe a
Just (Defaults -> Maybe Defaults) -> Defaults -> Maybe Defaults
forall a b. (a -> b) -> a -> b
$ Defaults
ss Defaults -> Defaults -> Defaults
forall a. Semigroup a => a -> a -> a
<> Defaults
entry
            )
            TableName
tName
            AllDefaults
m

getAllConstraints :: Pg.Connection -> IO AllTableConstraints
getAllConstraints :: Connection -> IO AllTableConstraints
getAllConstraints Connection
conn = do
  ReferenceActions
allActions <- [RefEntry] -> ReferenceActions
mkActions ([RefEntry] -> ReferenceActions)
-> IO [RefEntry] -> IO ReferenceActions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> IO [RefEntry]
forall r. FromRow r => Connection -> Query -> IO [r]
Pg.query_ Connection
conn Query
referenceActionsQ
  AllTableConstraints
allForeignKeys <- Connection
-> Query
-> AllTableConstraints
-> (AllTableConstraints
    -> SqlForeignConstraint -> IO AllTableConstraints)
-> IO AllTableConstraints
forall r a.
FromRow r =>
Connection -> Query -> a -> (a -> r -> IO a) -> IO a
Pg.fold_ Connection
conn Query
foreignKeysQ AllTableConstraints
forall a. Monoid a => a
mempty (\AllTableConstraints
acc -> AllTableConstraints -> IO AllTableConstraints
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AllTableConstraints -> IO AllTableConstraints)
-> (SqlForeignConstraint -> AllTableConstraints)
-> SqlForeignConstraint
-> IO AllTableConstraints
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReferenceActions
-> AllTableConstraints
-> SqlForeignConstraint
-> AllTableConstraints
addFkConstraint ReferenceActions
allActions AllTableConstraints
acc)
  Connection
-> Query
-> AllTableConstraints
-> (AllTableConstraints
    -> SqlOtherConstraint -> IO AllTableConstraints)
-> IO AllTableConstraints
forall r a.
FromRow r =>
Connection -> Query -> a -> (a -> r -> IO a) -> IO a
Pg.fold_ Connection
conn Query
otherConstraintsQ AllTableConstraints
allForeignKeys (\AllTableConstraints
acc -> AllTableConstraints -> IO AllTableConstraints
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AllTableConstraints -> IO AllTableConstraints)
-> (SqlOtherConstraint -> AllTableConstraints)
-> SqlOtherConstraint
-> IO AllTableConstraints
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllTableConstraints -> SqlOtherConstraint -> AllTableConstraints
addOtherConstraint AllTableConstraints
acc)
  where
    addFkConstraint ::
      ReferenceActions ->
      AllTableConstraints ->
      SqlForeignConstraint ->
      AllTableConstraints
    addFkConstraint :: ReferenceActions
-> AllTableConstraints
-> SqlForeignConstraint
-> AllTableConstraints
addFkConstraint ReferenceActions
actions AllTableConstraints
st SqlForeignConstraint {Text
Vector ColumnName
TableName
sqlFk_name :: Text
sqlFk_pk_columns :: Vector ColumnName
sqlFk_fk_columns :: Vector ColumnName
sqlFk_primary_table :: TableName
sqlFk_foreign_table :: TableName
sqlFk_name :: SqlForeignConstraint -> Text
sqlFk_pk_columns :: SqlForeignConstraint -> Vector ColumnName
sqlFk_fk_columns :: SqlForeignConstraint -> Vector ColumnName
sqlFk_primary_table :: SqlForeignConstraint -> TableName
sqlFk_foreign_table :: SqlForeignConstraint -> TableName
..} = (State AllTableConstraints ()
 -> AllTableConstraints -> AllTableConstraints)
-> AllTableConstraints
-> State AllTableConstraints ()
-> AllTableConstraints
forall a b c. (a -> b -> c) -> b -> a -> c
flip State AllTableConstraints ()
-> AllTableConstraints -> AllTableConstraints
forall s a. State s a -> s -> s
execState AllTableConstraints
st (State AllTableConstraints () -> AllTableConstraints)
-> State AllTableConstraints () -> AllTableConstraints
forall a b. (a -> b) -> a -> b
$ do
      let currentTable :: TableName
currentTable = TableName
sqlFk_foreign_table
      let columnSet :: Set (ColumnName, ColumnName)
columnSet = [(ColumnName, ColumnName)] -> Set (ColumnName, ColumnName)
forall a. Ord a => [a] -> Set a
S.fromList ([(ColumnName, ColumnName)] -> Set (ColumnName, ColumnName))
-> [(ColumnName, ColumnName)] -> Set (ColumnName, ColumnName)
forall a b. (a -> b) -> a -> b
$ [ColumnName] -> [ColumnName] -> [(ColumnName, ColumnName)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Vector ColumnName -> [ColumnName]
forall a. Vector a -> [a]
V.toList Vector ColumnName
sqlFk_fk_columns) (Vector ColumnName -> [ColumnName]
forall a. Vector a -> [a]
V.toList Vector ColumnName
sqlFk_pk_columns)
      let (ReferenceAction
onDelete, ReferenceAction
onUpdate) =
            case Text -> Map Text Actions -> Maybe Actions
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
sqlFk_name (ReferenceActions -> Map Text Actions
getActions ReferenceActions
actions) of
              Maybe Actions
Nothing -> (ReferenceAction
NoAction, ReferenceAction
NoAction)
              Just Actions
a -> (Actions -> ReferenceAction
actionOnDelete Actions
a, Actions -> ReferenceAction
actionOnUpdate Actions
a)
      TableName -> TableConstraint -> State AllTableConstraints ()
addTableConstraint TableName
currentTable (Text
-> TableName
-> Set (ColumnName, ColumnName)
-> ReferenceAction
-> ReferenceAction
-> TableConstraint
ForeignKey Text
sqlFk_name TableName
sqlFk_primary_table Set (ColumnName, ColumnName)
columnSet ReferenceAction
onDelete ReferenceAction
onUpdate)

    addOtherConstraint ::
      AllTableConstraints ->
      SqlOtherConstraint ->
      AllTableConstraints
    addOtherConstraint :: AllTableConstraints -> SqlOtherConstraint -> AllTableConstraints
addOtherConstraint AllTableConstraints
st SqlOtherConstraint {Text
Vector ColumnName
TableName
SqlRawOtherConstraintType
sqlCon_fk_colums :: Vector ColumnName
sqlCon_table :: TableName
sqlCon_constraint_type :: SqlRawOtherConstraintType
sqlCon_name :: Text
sqlCon_fk_colums :: SqlOtherConstraint -> Vector ColumnName
sqlCon_table :: SqlOtherConstraint -> TableName
sqlCon_constraint_type :: SqlOtherConstraint -> SqlRawOtherConstraintType
sqlCon_name :: SqlOtherConstraint -> Text
..} = (State AllTableConstraints ()
 -> AllTableConstraints -> AllTableConstraints)
-> AllTableConstraints
-> State AllTableConstraints ()
-> AllTableConstraints
forall a b c. (a -> b -> c) -> b -> a -> c
flip State AllTableConstraints ()
-> AllTableConstraints -> AllTableConstraints
forall s a. State s a -> s -> s
execState AllTableConstraints
st (State AllTableConstraints () -> AllTableConstraints)
-> State AllTableConstraints () -> AllTableConstraints
forall a b. (a -> b) -> a -> b
$ do
      let currentTable :: TableName
currentTable = TableName
sqlCon_table
      let columnSet :: Set ColumnName
columnSet = [ColumnName] -> Set ColumnName
forall a. Ord a => [a] -> Set a
S.fromList ([ColumnName] -> Set ColumnName)
-> (Vector ColumnName -> [ColumnName])
-> Vector ColumnName
-> Set ColumnName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector ColumnName -> [ColumnName]
forall a. Vector a -> [a]
V.toList (Vector ColumnName -> Set ColumnName)
-> Vector ColumnName -> Set ColumnName
forall a b. (a -> b) -> a -> b
$ Vector ColumnName
sqlCon_fk_colums
      case SqlRawOtherConstraintType
sqlCon_constraint_type of
        SqlRawOtherConstraintType
SQL_raw_unique -> TableName -> TableConstraint -> State AllTableConstraints ()
addTableConstraint TableName
currentTable (Text -> Set ColumnName -> TableConstraint
Unique Text
sqlCon_name Set ColumnName
columnSet)
        SqlRawOtherConstraintType
SQL_raw_pk -> if Set ColumnName -> Bool
forall a. Set a -> Bool
S.null Set ColumnName
columnSet then () -> State AllTableConstraints ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else
          TableName -> TableConstraint -> State AllTableConstraints ()
addTableConstraint TableName
currentTable (Text -> Set ColumnName -> TableConstraint
PrimaryKey Text
sqlCon_name Set ColumnName
columnSet)

newtype ReferenceActions = ReferenceActions {ReferenceActions -> Map Text Actions
getActions :: Map Text Actions}

newtype RefEntry = RefEntry {RefEntry -> (Text, ReferenceAction, ReferenceAction)
unRefEntry :: (Text, ReferenceAction, ReferenceAction)}

mkActions :: [RefEntry] -> ReferenceActions
mkActions :: [RefEntry] -> ReferenceActions
mkActions = Map Text Actions -> ReferenceActions
ReferenceActions (Map Text Actions -> ReferenceActions)
-> ([RefEntry] -> Map Text Actions)
-> [RefEntry]
-> ReferenceActions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Actions)] -> Map Text Actions
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, Actions)] -> Map Text Actions)
-> ([RefEntry] -> [(Text, Actions)])
-> [RefEntry]
-> Map Text Actions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RefEntry -> (Text, Actions)) -> [RefEntry] -> [(Text, Actions)]
forall a b. (a -> b) -> [a] -> [b]
map ((\(Text
a, ReferenceAction
b, ReferenceAction
c) -> (Text
a, ReferenceAction -> ReferenceAction -> Actions
Actions ReferenceAction
b ReferenceAction
c)) ((Text, ReferenceAction, ReferenceAction) -> (Text, Actions))
-> (RefEntry -> (Text, ReferenceAction, ReferenceAction))
-> RefEntry
-> (Text, Actions)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RefEntry -> (Text, ReferenceAction, ReferenceAction)
unRefEntry)

instance Pg.FromRow RefEntry where
  fromRow :: RowParser RefEntry
fromRow =
    ((Text, ReferenceAction, ReferenceAction) -> RefEntry)
-> RowParser (Text, ReferenceAction, ReferenceAction)
-> RowParser RefEntry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (Text, ReferenceAction, ReferenceAction) -> RefEntry
RefEntry
      ( (,,) (Text
 -> ReferenceAction
 -> ReferenceAction
 -> (Text, ReferenceAction, ReferenceAction))
-> RowParser Text
-> RowParser
     (ReferenceAction
      -> ReferenceAction -> (Text, ReferenceAction, ReferenceAction))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser Text
forall a. FromField a => RowParser a
field
          RowParser
  (ReferenceAction
   -> ReferenceAction -> (Text, ReferenceAction, ReferenceAction))
-> RowParser ReferenceAction
-> RowParser
     (ReferenceAction -> (Text, ReferenceAction, ReferenceAction))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> ReferenceAction)
-> RowParser Text -> RowParser ReferenceAction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ReferenceAction
mkAction RowParser Text
forall a. FromField a => RowParser a
field
          RowParser
  (ReferenceAction -> (Text, ReferenceAction, ReferenceAction))
-> RowParser ReferenceAction
-> RowParser (Text, ReferenceAction, ReferenceAction)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> ReferenceAction)
-> RowParser Text -> RowParser ReferenceAction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ReferenceAction
mkAction RowParser Text
forall a. FromField a => RowParser a
field
      )

data Actions = Actions
  { Actions -> ReferenceAction
actionOnDelete :: ReferenceAction,
    Actions -> ReferenceAction
actionOnUpdate :: ReferenceAction
  }

mkAction :: Text -> ReferenceAction
mkAction :: Text -> ReferenceAction
mkAction Text
c = case Text
c of
  Text
"a" -> ReferenceAction
NoAction
  Text
"r" -> ReferenceAction
Restrict
  Text
"c" -> ReferenceAction
Cascade
  Text
"n" -> ReferenceAction
SetNull
  Text
"d" -> ReferenceAction
SetDefault
  Text
_ -> String -> ReferenceAction
forall a. HasCallStack => String -> a
error (String -> ReferenceAction)
-> (Text -> String) -> Text -> ReferenceAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> ReferenceAction) -> Text -> ReferenceAction
forall a b. (a -> b) -> a -> b
$ Text
"unknown reference action type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c

--
-- Useful combinators to add constraints for a column or table if already there.
--

addTableConstraint ::
  TableName ->
  TableConstraint ->
  State AllTableConstraints ()
addTableConstraint :: TableName -> TableConstraint -> State AllTableConstraints ()
addTableConstraint TableName
tName TableConstraint
cns =
  (AllTableConstraints -> AllTableConstraints)
-> State AllTableConstraints ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify'
    ( (Maybe (Set TableConstraint) -> Maybe (Set TableConstraint))
-> TableName -> AllTableConstraints -> AllTableConstraints
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter
        ( \case
            Maybe (Set TableConstraint)
Nothing -> Set TableConstraint -> Maybe (Set TableConstraint)
forall a. a -> Maybe a
Just (Set TableConstraint -> Maybe (Set TableConstraint))
-> Set TableConstraint -> Maybe (Set TableConstraint)
forall a b. (a -> b) -> a -> b
$ TableConstraint -> Set TableConstraint
forall a. a -> Set a
S.singleton TableConstraint
cns
            Just Set TableConstraint
ss -> Set TableConstraint -> Maybe (Set TableConstraint)
forall a. a -> Maybe a
Just (Set TableConstraint -> Maybe (Set TableConstraint))
-> Set TableConstraint -> Maybe (Set TableConstraint)
forall a b. (a -> b) -> a -> b
$ TableConstraint -> Set TableConstraint -> Set TableConstraint
forall a. Ord a => a -> Set a -> Set a
S.insert TableConstraint
cns Set TableConstraint
ss
        )
        TableName
tName
    )