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

import Control.Monad
import qualified Data.Foldable 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
domChecks :: Domain -> Set Check
domDefault :: Domain -> Maybe (RawSQL ())
domNullable :: Domain -> Bool
domType :: Domain -> ColumnType
domName :: Domain -> RawSQL ()
domChecks :: Set Check
domDefault :: Maybe (RawSQL ())
domNullable :: Bool
domType :: ColumnType
domName :: RawSQL ()
..} = do
  -- create the domain
  forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ Domain -> RawSQL ()
sqlCreateDomain Domain
dom
  -- add constraint checks to the domain
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ Set Check
domChecks forall a b. (a -> b) -> a -> b
$ forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> RawSQL () -> RawSQL ()
sqlAlterDomain RawSQL ()
domName 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 ()
tblInitialSetup :: Table -> Maybe TableInitialSetup
tblTriggers :: Table -> [Trigger]
tblIndexes :: Table -> [TableIndex]
tblForeignKeys :: Table -> [ForeignKey]
tblChecks :: Table -> [Check]
tblPrimaryKey :: Table -> Maybe PrimaryKey
tblColumns :: Table -> [TableColumn]
tblVersion :: Table -> Int32
tblName :: Table -> RawSQL ()
tblInitialSetup :: Maybe TableInitialSetup
tblTriggers :: [Trigger]
tblIndexes :: [TableIndex]
tblForeignKeys :: [ForeignKey]
tblChecks :: [Check]
tblPrimaryKey :: Maybe PrimaryKey
tblColumns :: [TableColumn]
tblVersion :: Int32
tblName :: RawSQL ()
..} = do
  -- Create empty table and add the columns.
  forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ RawSQL () -> RawSQL ()
sqlCreateTable RawSQL ()
tblName
  forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ RawSQL () -> [RawSQL ()] -> RawSQL ()
sqlAlterTable RawSQL ()
tblName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TableColumn -> RawSQL ()
sqlAddColumn [TableColumn]
tblColumns
  -- Add indexes.
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TableIndex]
tblIndexes forall a b. (a -> b) -> a -> b
$ forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> TableIndex -> RawSQL ()
sqlCreateIndexMaybeDowntime RawSQL ()
tblName
  -- Add all the other constraints if applicable.
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
withConstraints forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadDB m => Table -> m ()
createTableConstraints Table
table
  -- Create triggers.
  forall (m :: * -> *). MonadDB m => Table -> m ()
createTableTriggers Table
table
  -- Register the table along with its version.
  forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlInsert () -> SqlInsert
sqlInsert SQL
"table_versions" forall a b. (a -> b) -> a -> b
$ do
    forall v (m :: * -> *) a.
(MonadState v m, SqlSet v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlSet SQL
"name" (Table -> Text
tblNameText Table
table)
    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 ()
tblInitialSetup :: Maybe TableInitialSetup
tblTriggers :: [Trigger]
tblIndexes :: [TableIndex]
tblForeignKeys :: [ForeignKey]
tblChecks :: [Check]
tblPrimaryKey :: Maybe PrimaryKey
tblColumns :: [TableColumn]
tblVersion :: Int32
tblName :: RawSQL ()
tblInitialSetup :: Table -> Maybe TableInitialSetup
tblTriggers :: Table -> [Trigger]
tblIndexes :: Table -> [TableIndex]
tblForeignKeys :: Table -> [ForeignKey]
tblChecks :: Table -> [Check]
tblPrimaryKey :: Table -> Maybe PrimaryKey
tblColumns :: Table -> [TableColumn]
tblVersion :: Table -> Int32
tblName :: Table -> RawSQL ()
..} = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RawSQL ()]
addConstraints) forall a b. (a -> b) -> a -> b
$ do
  forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ RawSQL () -> [RawSQL ()] -> RawSQL ()
sqlAlterTable RawSQL ()
tblName [RawSQL ()]
addConstraints
  where
    addConstraints :: [RawSQL ()]
addConstraints = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
        [RawSQL () -> PrimaryKey -> RawSQL ()
sqlAddPK RawSQL ()
tblName PrimaryKey
pk | Just PrimaryKey
pk <- forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PrimaryKey
tblPrimaryKey]
      , forall a b. (a -> b) -> [a] -> [b]
map Check -> RawSQL ()
sqlAddValidCheckMaybeDowntime [Check]
tblChecks
      , 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 = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). MonadDB m => Trigger -> m ()
createTrigger forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> [Trigger]
tblTriggers