module Database.PostgreSQL.PQTypes.Migrate
  ( createDomain
  , createTable
  , createTableConstraints
  , createTableTriggers
  ) where

import Control.Monad
import Data.Foldable qualified as F

import Database.PostgreSQL.PQTypes
import Database.PostgreSQL.PQTypes.Checks.Util
import Database.PostgreSQL.PQTypes.Model
import Database.PostgreSQL.PQTypes.SQL.Builder

createDomain :: MonadDB m => Domain -> m ()
createDomain :: forall (m :: * -> *). MonadDB m => Domain -> m ()
createDomain dom :: Domain
dom@Domain {Bool
Maybe (RawSQL ())
Set Check
RawSQL ()
ColumnType
domName :: RawSQL ()
domType :: ColumnType
domNullable :: Bool
domDefault :: Maybe (RawSQL ())
domChecks :: Set Check
domName :: Domain -> RawSQL ()
domType :: Domain -> ColumnType
domNullable :: Domain -> Bool
domDefault :: Domain -> Maybe (RawSQL ())
domChecks :: Domain -> Set Check
..} = do
  -- create the domain
  RawSQL () -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (RawSQL () -> m ()) -> RawSQL () -> m ()
forall a b. (a -> b) -> a -> b
$ Domain -> RawSQL ()
sqlCreateDomain Domain
dom
  -- add constraint checks to the domain
  Set Check -> (Check -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ Set Check
domChecks ((Check -> m ()) -> m ()) -> (Check -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (RawSQL () -> m ()) -> (Check -> RawSQL ()) -> Check -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> RawSQL () -> RawSQL ()
sqlAlterDomain RawSQL ()
domName (RawSQL () -> RawSQL ())
-> (Check -> RawSQL ()) -> Check -> RawSQL ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Check -> RawSQL ()
sqlAddValidCheckMaybeDowntime

createTable :: MonadDB m => Bool -> Table -> m ()
createTable :: forall (m :: * -> *). MonadDB m => Bool -> Table -> m ()
createTable Bool
withConstraints table :: Table
table@Table {Int32
[Check]
[ForeignKey]
[TableIndex]
[Trigger]
[TableColumn]
Maybe PrimaryKey
Maybe TableInitialSetup
RawSQL ()
tblName :: RawSQL ()
tblVersion :: Int32
tblColumns :: [TableColumn]
tblPrimaryKey :: Maybe PrimaryKey
tblChecks :: [Check]
tblForeignKeys :: [ForeignKey]
tblIndexes :: [TableIndex]
tblTriggers :: [Trigger]
tblInitialSetup :: Maybe TableInitialSetup
tblName :: Table -> RawSQL ()
tblVersion :: Table -> Int32
tblColumns :: Table -> [TableColumn]
tblPrimaryKey :: Table -> Maybe PrimaryKey
tblChecks :: Table -> [Check]
tblForeignKeys :: Table -> [ForeignKey]
tblIndexes :: Table -> [TableIndex]
tblTriggers :: Table -> [Trigger]
tblInitialSetup :: Table -> Maybe TableInitialSetup
..} = do
  -- Create empty table and add the columns.
  RawSQL () -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (RawSQL () -> m ()) -> RawSQL () -> m ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> RawSQL ()
sqlCreateTable RawSQL ()
tblName
  RawSQL () -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (RawSQL () -> m ()) -> RawSQL () -> m ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> [RawSQL ()] -> RawSQL ()
sqlAlterTable RawSQL ()
tblName ([RawSQL ()] -> RawSQL ()) -> [RawSQL ()] -> RawSQL ()
forall a b. (a -> b) -> a -> b
$ (TableColumn -> RawSQL ()) -> [TableColumn] -> [RawSQL ()]
forall a b. (a -> b) -> [a] -> [b]
map TableColumn -> RawSQL ()
sqlAddColumn [TableColumn]
tblColumns
  -- Add the primary key if applicable.
  Maybe PrimaryKey -> (PrimaryKey -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe PrimaryKey
tblPrimaryKey ((PrimaryKey -> m ()) -> m ()) -> (PrimaryKey -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \PrimaryKey
pk -> RawSQL () -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (RawSQL () -> m ()) -> RawSQL () -> m ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> [RawSQL ()] -> RawSQL ()
sqlAlterTable RawSQL ()
tblName [RawSQL () -> PrimaryKey -> RawSQL ()
sqlAddPK RawSQL ()
tblName PrimaryKey
pk]
  -- Add indexes.
  [TableIndex] -> (TableIndex -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TableIndex]
tblIndexes ((TableIndex -> m ()) -> m ()) -> (TableIndex -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (RawSQL () -> m ())
-> (TableIndex -> RawSQL ()) -> TableIndex -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> TableIndex -> RawSQL ()
sqlCreateIndexMaybeDowntime RawSQL ()
tblName
  -- Add all the other constraints if applicable.
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
withConstraints (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Table -> m ()
forall (m :: * -> *). MonadDB m => Table -> m ()
createTableConstraints Table
table
  -- Create triggers.
  Table -> m ()
forall (m :: * -> *). MonadDB m => Table -> m ()
createTableTriggers Table
table
  -- Register the table along with its version.
  SqlInsert -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (SqlInsert -> m ())
-> (State SqlInsert () -> SqlInsert) -> State SqlInsert () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlInsert () -> SqlInsert
sqlInsert SQL
"table_versions" (State SqlInsert () -> m ()) -> State SqlInsert () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    SQL -> Text -> State SqlInsert ()
forall v (m :: * -> *) a.
(MonadState v m, SqlSet v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlSet SQL
"name" (Table -> Text
tblNameText Table
table)
    SQL -> Int32 -> State SqlInsert ()
forall v (m :: * -> *) a.
(MonadState v m, SqlSet v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlSet SQL
"version" Int32
tblVersion

createTableConstraints :: MonadDB m => Table -> m ()
createTableConstraints :: forall (m :: * -> *). MonadDB m => Table -> m ()
createTableConstraints Table {Int32
[Check]
[ForeignKey]
[TableIndex]
[Trigger]
[TableColumn]
Maybe PrimaryKey
Maybe TableInitialSetup
RawSQL ()
tblName :: Table -> RawSQL ()
tblVersion :: Table -> Int32
tblColumns :: Table -> [TableColumn]
tblPrimaryKey :: Table -> Maybe PrimaryKey
tblChecks :: Table -> [Check]
tblForeignKeys :: Table -> [ForeignKey]
tblIndexes :: Table -> [TableIndex]
tblTriggers :: Table -> [Trigger]
tblInitialSetup :: Table -> Maybe TableInitialSetup
tblName :: RawSQL ()
tblVersion :: Int32
tblColumns :: [TableColumn]
tblPrimaryKey :: Maybe PrimaryKey
tblChecks :: [Check]
tblForeignKeys :: [ForeignKey]
tblIndexes :: [TableIndex]
tblTriggers :: [Trigger]
tblInitialSetup :: Maybe TableInitialSetup
..} = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([RawSQL ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RawSQL ()]
addConstraints) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  RawSQL () -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (RawSQL () -> m ()) -> RawSQL () -> m ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> [RawSQL ()] -> RawSQL ()
sqlAlterTable RawSQL ()
tblName [RawSQL ()]
addConstraints
  where
    addConstraints :: [RawSQL ()]
addConstraints =
      (Check -> RawSQL ()) -> [Check] -> [RawSQL ()]
forall a b. (a -> b) -> [a] -> [b]
map Check -> RawSQL ()
sqlAddValidCheckMaybeDowntime [Check]
tblChecks
        [RawSQL ()] -> [RawSQL ()] -> [RawSQL ()]
forall a. [a] -> [a] -> [a]
++ (ForeignKey -> RawSQL ()) -> [ForeignKey] -> [RawSQL ()]
forall a b. (a -> b) -> [a] -> [b]
map (RawSQL () -> ForeignKey -> RawSQL ()
sqlAddValidFKMaybeDowntime RawSQL ()
tblName) [ForeignKey]
tblForeignKeys

createTableTriggers :: MonadDB m => Table -> m ()
createTableTriggers :: forall (m :: * -> *). MonadDB m => Table -> m ()
createTableTriggers = (Trigger -> m ()) -> [Trigger] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Trigger -> m ()
forall (m :: * -> *). MonadDB m => Trigger -> m ()
createTrigger ([Trigger] -> m ()) -> (Table -> [Trigger]) -> Table -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> [Trigger]
tblTriggers