module Database.PostgreSQL.PQTypes.Checks
  ( -- * Definitions
    DatabaseDefinitions (..)
  , emptyDbDefinitions

    -- * Checks
  , checkDatabase
  , checkDatabaseWithReport
  , createTable
  , createDomain

    -- * Options
  , ExtrasOptions (..)
  , defaultExtrasOptions
  , ObjectsValidationMode (..)

    -- * Migrations
  , migrateDatabase

    -- * Internals for tests
  , ValidationResult
  , validationError
  , validationInfo
  ) where

import Control.Arrow ((&&&))
import Control.Concurrent (threadDelay)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Extra (mconcatMapM)
import Control.Monad.Writer as W
import Data.Foldable (foldMap')
import Data.Function
import Data.Int
import Data.List (partition)
import Data.List qualified as L
import Data.Map qualified as M
import Data.Maybe
import Data.Monoid.Utils
import Data.Set qualified as S
import Data.String qualified
import Data.Text (Text)
import Data.Text qualified as T
import Data.Typeable (cast)
import Database.PostgreSQL.PQTypes
import GHC.Stack (HasCallStack)
import Log
import TextShow

import Database.PostgreSQL.PQTypes.Checks.Util
import Database.PostgreSQL.PQTypes.ExtrasOptions
import Database.PostgreSQL.PQTypes.Migrate
import Database.PostgreSQL.PQTypes.Model
import Database.PostgreSQL.PQTypes.SQL.Builder
import Database.PostgreSQL.PQTypes.Versions

headExc :: String -> [a] -> a
headExc :: forall a. String -> [a] -> a
headExc String
s [] = String -> a
forall a. HasCallStack => String -> a
error String
s
headExc String
_ (a
x : [a]
_) = a
x

data DatabaseDefinitions = DatabaseDefinitions
  { DatabaseDefinitions -> [Extension]
dbExtensions :: [Extension]
  , DatabaseDefinitions -> [CompositeType]
dbComposites :: [CompositeType]
  , DatabaseDefinitions -> [EnumType]
dbEnums :: [EnumType]
  , DatabaseDefinitions -> [Domain]
dbDomains :: [Domain]
  , DatabaseDefinitions -> [Table]
dbTables :: [Table]
  }

emptyDbDefinitions :: DatabaseDefinitions
emptyDbDefinitions :: DatabaseDefinitions
emptyDbDefinitions = [Extension]
-> [CompositeType]
-> [EnumType]
-> [Domain]
-> [Table]
-> DatabaseDefinitions
DatabaseDefinitions [] [] [] [] []

----------------------------------------

-- | Run migrations and check the database structure.
migrateDatabase
  :: (MonadIO m, MonadDB m, MonadLog m, MonadMask m)
  => ExtrasOptions
  -> DatabaseDefinitions
  -> [Migration m]
  -> m ()
migrateDatabase :: forall (m :: * -> *).
(MonadIO m, MonadDB m, MonadLog m, MonadMask m) =>
ExtrasOptions -> DatabaseDefinitions -> [Migration m] -> m ()
migrateDatabase
  ExtrasOptions
options
  DatabaseDefinitions
    { dbExtensions :: DatabaseDefinitions -> [Extension]
dbExtensions = [Extension]
extensions
    , dbComposites :: DatabaseDefinitions -> [CompositeType]
dbComposites = [CompositeType]
composites
    , dbEnums :: DatabaseDefinitions -> [EnumType]
dbEnums = [EnumType]
enums
    , dbDomains :: DatabaseDefinitions -> [Domain]
dbDomains = [Domain]
domains
    , dbTables :: DatabaseDefinitions -> [Table]
dbTables = [Table]
tables
    }
  [Migration m]
migrations = do
    m ()
forall (m :: * -> *). (MonadDB m, MonadLog m, MonadThrow m) => m ()
setDBTimeZoneToUTC
    (Extension -> m ()) -> [Extension] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Extension -> m ()
forall (m :: * -> *).
(MonadDB m, MonadLog m, MonadThrow m) =>
Extension -> m ()
checkExtension [Extension]
extensions
    TablesWithVersions
tablesWithVersions <- [Table] -> m TablesWithVersions
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Table] -> m TablesWithVersions
getTableVersions (Table
tableVersions Table -> [Table] -> [Table]
forall a. a -> [a] -> [a]
: [Table]
tables)
    -- 'checkDBConsistency' also performs migrations.
    ExtrasOptions
-> [Domain]
-> [EnumType]
-> TablesWithVersions
-> [Migration m]
-> m ()
forall (m :: * -> *).
(MonadIO m, MonadDB m, MonadLog m, MonadMask m) =>
ExtrasOptions
-> [Domain]
-> [EnumType]
-> TablesWithVersions
-> [Migration m]
-> m ()
checkDBConsistency ExtrasOptions
options [Domain]
domains [EnumType]
enums TablesWithVersions
tablesWithVersions [Migration m]
migrations
    ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck
      (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> m ValidationResult
forall (m :: * -> *).
MonadDB m =>
TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> m ValidationResult
checkCompositesStructure
        TablesWithVersions
tablesWithVersions
        CompositesCreationMode
CreateCompositesIfDatabaseEmpty
        (ExtrasOptions -> ObjectsValidationMode
eoObjectsValidationMode ExtrasOptions
options)
        [CompositeType]
composites
    ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [EnumType] -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[EnumType] -> m ValidationResult
checkEnumTypes [EnumType]
enums
    ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Domain] -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Domain] -> m ValidationResult
checkDomainsStructure [Domain]
domains
    ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExtrasOptions -> TablesWithVersions -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
ExtrasOptions -> TablesWithVersions -> m ValidationResult
checkDBStructure ExtrasOptions
options TablesWithVersions
tablesWithVersions
    ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Migration m] -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Migration m] -> m ValidationResult
checkTablesWereDropped [Migration m]
migrations

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExtrasOptions -> ObjectsValidationMode
eoObjectsValidationMode ExtrasOptions
options ObjectsValidationMode -> ObjectsValidationMode -> Bool
forall a. Eq a => a -> a -> Bool
== ObjectsValidationMode
DontAllowUnknownObjects) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Table] -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkUnknownTables [Table]
tables
      ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Table] -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkExistenceOfVersionsForTables (Table
tableVersions Table -> [Table] -> [Table]
forall a. a -> [a] -> [a]
: [Table]
tables)

    -- After migrations are done make sure the table versions are correct.
    ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ())
-> (TablesWithVersions -> ValidationResult)
-> TablesWithVersions
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtrasOptions -> TablesWithVersions -> ValidationResult
checkVersions ExtrasOptions
options (TablesWithVersions -> m ()) -> m TablesWithVersions -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Table] -> m TablesWithVersions
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Table] -> m TablesWithVersions
getTableVersions (Table
tableVersions Table -> [Table] -> [Table]
forall a. a -> [a] -> [a]
: [Table]
tables)

    -- everything is OK, commit changes
    m ()
forall (m :: * -> *). (HasCallStack, MonadDB m) => m ()
commit

-- | Run checks on the database structure and whether the database needs to be
-- migrated. Will do a full check of DB structure.
checkDatabaseWithReport
  :: forall m
   . (MonadDB m, MonadLog m, MonadThrow m)
  => ExtrasOptions
  -> DatabaseDefinitions
  -> m ValidationResult
checkDatabaseWithReport :: forall (m :: * -> *).
(MonadDB m, MonadLog m, MonadThrow m) =>
ExtrasOptions -> DatabaseDefinitions -> m ValidationResult
checkDatabaseWithReport
  ExtrasOptions
options
  DatabaseDefinitions
    { dbExtensions :: DatabaseDefinitions -> [Extension]
dbExtensions = [Extension]
_
    , dbComposites :: DatabaseDefinitions -> [CompositeType]
dbComposites = [CompositeType]
composites
    , dbEnums :: DatabaseDefinitions -> [EnumType]
dbEnums = [EnumType]
enums
    , dbDomains :: DatabaseDefinitions -> [Domain]
dbDomains = [Domain]
domains
    , dbTables :: DatabaseDefinitions -> [Table]
dbTables = [Table]
tables
    } = WriterT ValidationResult m () -> m ValidationResult
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT ValidationResult m () -> m ValidationResult)
-> WriterT ValidationResult m () -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ do
    (()
_, ValidationResult
report) <- WriterT ValidationResult m ()
-> WriterT ValidationResult m ((), ValidationResult)
forall a.
WriterT ValidationResult m a
-> WriterT ValidationResult m (a, ValidationResult)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
W.listen (WriterT ValidationResult m ()
 -> WriterT ValidationResult m ((), ValidationResult))
-> WriterT ValidationResult m ()
-> WriterT ValidationResult m ((), ValidationResult)
forall a b. (a -> b) -> a -> b
$ do
      TablesWithVersions
tablesWithVersions <- [Table] -> WriterT ValidationResult m TablesWithVersions
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Table] -> m TablesWithVersions
getTableVersions (Table
tableVersions Table -> [Table] -> [Table]
forall a. a -> [a] -> [a]
: [Table]
tables)
      ValidationResult -> WriterT ValidationResult m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (ValidationResult -> WriterT ValidationResult m ())
-> ValidationResult -> WriterT ValidationResult m ()
forall a b. (a -> b) -> a -> b
$ ExtrasOptions -> TablesWithVersions -> ValidationResult
checkVersions ExtrasOptions
options TablesWithVersions
tablesWithVersions
      ValidationResult -> WriterT ValidationResult m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
        (ValidationResult -> WriterT ValidationResult m ())
-> WriterT ValidationResult m ValidationResult
-> WriterT ValidationResult m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> WriterT ValidationResult m ValidationResult
forall (m :: * -> *).
MonadDB m =>
TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> m ValidationResult
checkCompositesStructure
          TablesWithVersions
tablesWithVersions
          CompositesCreationMode
DontCreateComposites
          (ExtrasOptions -> ObjectsValidationMode
eoObjectsValidationMode ExtrasOptions
options)
          [CompositeType]
composites
      ValidationResult -> WriterT ValidationResult m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (ValidationResult -> WriterT ValidationResult m ())
-> WriterT ValidationResult m ValidationResult
-> WriterT ValidationResult m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [EnumType] -> WriterT ValidationResult m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[EnumType] -> m ValidationResult
checkEnumTypes [EnumType]
enums
      ValidationResult -> WriterT ValidationResult m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (ValidationResult -> WriterT ValidationResult m ())
-> WriterT ValidationResult m ValidationResult
-> WriterT ValidationResult m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Domain] -> WriterT ValidationResult m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Domain] -> m ValidationResult
checkDomainsStructure [Domain]
domains
      ValidationResult -> WriterT ValidationResult m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (ValidationResult -> WriterT ValidationResult m ())
-> WriterT ValidationResult m ValidationResult
-> WriterT ValidationResult m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExtrasOptions
-> TablesWithVersions
-> WriterT ValidationResult m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
ExtrasOptions -> TablesWithVersions -> m ValidationResult
checkDBStructure ExtrasOptions
options TablesWithVersions
tablesWithVersions
      Bool
-> WriterT ValidationResult m () -> WriterT ValidationResult m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExtrasOptions -> ObjectsValidationMode
eoObjectsValidationMode ExtrasOptions
options ObjectsValidationMode -> ObjectsValidationMode -> Bool
forall a. Eq a => a -> a -> Bool
== ObjectsValidationMode
DontAllowUnknownObjects) (WriterT ValidationResult m () -> WriterT ValidationResult m ())
-> WriterT ValidationResult m () -> WriterT ValidationResult m ()
forall a b. (a -> b) -> a -> b
$ do
        ValidationResult -> WriterT ValidationResult m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (ValidationResult -> WriterT ValidationResult m ())
-> WriterT ValidationResult m ValidationResult
-> WriterT ValidationResult m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Table] -> WriterT ValidationResult m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkUnknownTables [Table]
tables
        ValidationResult -> WriterT ValidationResult m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (ValidationResult -> WriterT ValidationResult m ())
-> WriterT ValidationResult m ValidationResult
-> WriterT ValidationResult m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Table] -> WriterT ValidationResult m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkExistenceOfVersionsForTables (Table
tableVersions Table -> [Table] -> [Table]
forall a. a -> [a] -> [a]
: [Table]
tables)

    -- Check initial setups only after database structure is considered
    -- consistent as before that some of the checks may fail internally.
    Bool
-> WriterT ValidationResult m () -> WriterT ValidationResult m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ValidationResult -> Bool
resultHasErrors ValidationResult
report) (WriterT ValidationResult m () -> WriterT ValidationResult m ())
-> WriterT ValidationResult m () -> WriterT ValidationResult m ()
forall a b. (a -> b) -> a -> b
$
      ValidationResult -> WriterT ValidationResult m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (ValidationResult -> WriterT ValidationResult m ())
-> WriterT ValidationResult m ValidationResult
-> WriterT ValidationResult m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m ValidationResult -> WriterT ValidationResult m ValidationResult
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT ValidationResult m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ([Table] -> m ValidationResult
checkInitialSetups [Table]
tables)
    where
      checkInitialSetups :: [Table] -> m ValidationResult
      checkInitialSetups :: [Table] -> m ValidationResult
checkInitialSetups = (Table -> m ValidationResult) -> [Table] -> m ValidationResult
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
mconcatMapM Table -> m ValidationResult
forall {m :: * -> *}.
(MonadDB m, MonadThrow m) =>
Table -> m ValidationResult
checkInitialSetupForTable

      checkInitialSetupForTable :: Table -> m ValidationResult
checkInitialSetupForTable Table
table = case Table -> Maybe TableInitialSetup
tblInitialSetup Table
table of
        Maybe TableInitialSetup
Nothing -> ValidationResult -> m ValidationResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationResult
forall a. Monoid a => a
mempty
        Just TableInitialSetup
setup ->
          TableInitialSetup
-> forall (m :: * -> *). (MonadDB m, MonadThrow m) => m Bool
checkInitialSetup TableInitialSetup
setup m Bool -> (Bool -> m ValidationResult) -> m ValidationResult
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
True -> ValidationResult -> m ValidationResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationResult
forall a. Monoid a => a
mempty
            Bool
False ->
              ValidationResult -> m ValidationResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult -> m ValidationResult)
-> (Text -> ValidationResult) -> Text -> m ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ValidationResult
validationError (Text -> m ValidationResult) -> Text -> m ValidationResult
forall a b. (a -> b) -> a -> b
$
                Text
"Initial setup for table '"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Table -> Text
tblNameText Table
table
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' is not valid"

-- | An equivalent to `checkDatabaseWithReport opts dbDefs >>= resultCheck`.
checkDatabase
  :: forall m
   . (MonadDB m, MonadLog m, MonadThrow m)
  => ExtrasOptions
  -> DatabaseDefinitions
  -> m ()
checkDatabase :: forall (m :: * -> *).
(MonadDB m, MonadLog m, MonadThrow m) =>
ExtrasOptions -> DatabaseDefinitions -> m ()
checkDatabase ExtrasOptions
options DatabaseDefinitions
dbDefinitions =
  ExtrasOptions -> DatabaseDefinitions -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadLog m, MonadThrow m) =>
ExtrasOptions -> DatabaseDefinitions -> m ValidationResult
checkDatabaseWithReport ExtrasOptions
options DatabaseDefinitions
dbDefinitions m ValidationResult -> (ValidationResult -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck

-- | Return SQL fragment of current catalog within quotes
currentCatalog :: (MonadDB m, MonadThrow m) => m (RawSQL ())
currentCatalog :: forall (m :: * -> *). (MonadDB m, MonadThrow m) => m (RawSQL ())
currentCatalog = do
  SQL -> m ()
forall (m :: * -> *). (HasCallStack, MonadDB m) => SQL -> m ()
runSQL_ SQL
"SELECT current_catalog::text"
  String
dbname <- (Identity String -> String) -> m String
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m t
fetchOne Identity String -> String
forall a. Identity a -> a
runIdentity
  RawSQL () -> m (RawSQL ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (RawSQL () -> m (RawSQL ())) -> RawSQL () -> m (RawSQL ())
forall a b. (a -> b) -> a -> b
$ String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL (String -> RawSQL ()) -> String -> RawSQL ()
forall a b. (a -> b) -> a -> b
$ String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dbname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""

-- | Check for a given extension. We need to read from 'pg_extension'
-- table as Amazon RDS limits usage of 'CREATE EXTENSION IF NOT EXISTS'.
checkExtension :: (MonadDB m, MonadLog m, MonadThrow m) => Extension -> m ()
checkExtension :: forall (m :: * -> *).
(MonadDB m, MonadLog m, MonadThrow m) =>
Extension -> m ()
checkExtension (Extension RawSQL ()
extension) = do
  Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Checking for extension '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txtExtension Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
  Bool
extensionExists <- SqlSelect -> m Bool
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m, MonadThrow m) =>
sql -> m Bool
runQuery01 (SqlSelect -> m Bool)
-> (State SqlSelect () -> SqlSelect)
-> State SqlSelect ()
-> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_extension" (State SqlSelect () -> m Bool) -> State SqlSelect () -> m Bool
forall a b. (a -> b) -> a -> b
$ do
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"TRUE"
    SQL -> Text -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"extname" (Text -> State SqlSelect ()) -> Text -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
unRawSQL RawSQL ()
extension
  if Bool -> Bool
not Bool
extensionExists
    then do
      Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Creating extension '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txtExtension Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
      SQL -> m ()
forall (m :: * -> *). (HasCallStack, MonadDB m) => SQL -> m ()
runSQL_ (SQL -> m ()) -> SQL -> m ()
forall a b. (a -> b) -> a -> b
$ SQL
"CREATE EXTENSION IF NOT EXISTS" SQL -> SQL -> SQL
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> SQL
raw RawSQL ()
extension
    else Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Extension '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txtExtension Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' exists"
  where
    txtExtension :: Text
txtExtension = RawSQL () -> Text
unRawSQL RawSQL ()
extension

-- | Check whether the database returns timestamps in UTC, and set the
-- timezone to UTC if it doesn't.
setDBTimeZoneToUTC :: (MonadDB m, MonadLog m, MonadThrow m) => m ()
setDBTimeZoneToUTC :: forall (m :: * -> *). (MonadDB m, MonadLog m, MonadThrow m) => m ()
setDBTimeZoneToUTC = do
  SQL -> m ()
forall (m :: * -> *). (HasCallStack, MonadDB m) => SQL -> m ()
runSQL_ SQL
"SHOW timezone"
  String
timezone :: String <- (Identity String -> String) -> m String
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m t
fetchOne Identity String -> String
forall a. Identity a -> a
runIdentity
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
timezone String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"UTC") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    RawSQL ()
dbname <- m (RawSQL ())
forall (m :: * -> *). (MonadDB m, MonadThrow m) => m (RawSQL ())
currentCatalog
    Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
      Text
"Setting '"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RawSQL () -> Text
unRawSQL RawSQL ()
dbname
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' database to return timestamps in UTC"
    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 ()
"ALTER DATABASE" RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
dbname RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"SET TIMEZONE = 'UTC'"
    -- Setting the database timezone doesn't change the session timezone.
    SQL -> m ()
forall (m :: * -> *). (HasCallStack, MonadDB m) => SQL -> m ()
runSQL_ SQL
"SET timezone = 'UTC'"

-- | Get the names of all user-defined tables that actually exist in
-- the DB.
getDBTableNames :: MonadDB m => m [Text]
getDBTableNames :: forall (m :: * -> *). MonadDB m => m [Text]
getDBTableNames = do
  SqlSelect -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (SqlSelect -> m ()) -> SqlSelect -> m ()
forall a b. (a -> b) -> a -> b
$ SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"information_schema.tables" (State SqlSelect () -> SqlSelect)
-> State SqlSelect () -> SqlSelect
forall a b. (a -> b) -> a -> b
$ do
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"table_name::text"
    SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"table_name <> 'table_versions'"
    SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"table_type = 'BASE TABLE'"
    SqlSelect -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlWhere v) =>
SqlSelect -> m ()
sqlWhereExists (SqlSelect -> State SqlSelect ())
-> SqlSelect -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"unnest(current_schemas(false)) as cs" (State SqlSelect () -> SqlSelect)
-> State SqlSelect () -> SqlSelect
forall a b. (a -> b) -> a -> b
$ do
      SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"TRUE"
      SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"cs = table_schema"
  (Identity Text -> Text) -> m [Text]
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany Identity Text -> Text
forall a. Identity a -> a
runIdentity

checkVersions :: ExtrasOptions -> TablesWithVersions -> ValidationResult
checkVersions :: ExtrasOptions -> TablesWithVersions -> ValidationResult
checkVersions ExtrasOptions
options = [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat ([ValidationResult] -> ValidationResult)
-> (TablesWithVersions -> [ValidationResult])
-> TablesWithVersions
-> ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Table, Int32) -> ValidationResult)
-> TablesWithVersions -> [ValidationResult]
forall a b. (a -> b) -> [a] -> [b]
map (Table, Int32) -> ValidationResult
checkVersion
  where
    checkVersion :: (Table, Int32) -> ValidationResult
    checkVersion :: (Table, Int32) -> ValidationResult
checkVersion (t :: Table
t@Table {Int32
[Check]
[ForeignKey]
[TableIndex]
[Trigger]
[TableColumn]
Maybe PrimaryKey
Maybe TableInitialSetup
RawSQL ()
tblInitialSetup :: Table -> Maybe TableInitialSetup
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]
..}, Int32
v)
      | if ExtrasOptions -> Bool
eoAllowHigherTableVersions ExtrasOptions
options
          then Int32
tblVersion Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int32
v
          else Int32
tblVersion Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
v =
          ValidationResult
forall a. Monoid a => a
mempty
      | Int32
v Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
0 =
          Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
            Text
"Table '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Table -> Text
tblNameText Table
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' must be created"
      | Bool
otherwise =
          Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
            Text
"Table '"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Table -> Text
tblNameText Table
t
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' must be migrated"
              Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Int32 -> Text
forall a. TextShow a => a -> Text
showt Int32
v
              Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"->"
              Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Int32 -> Text
forall a. TextShow a => a -> Text
showt Int32
tblVersion

-- | Check that there's a 1-to-1 correspondence between the list of
-- 'Table's and what's actually in the database.
checkUnknownTables :: (MonadDB m, MonadLog m) => [Table] -> m ValidationResult
checkUnknownTables :: forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkUnknownTables [Table]
tables = do
  [Text]
dbTableNames <- m [Text]
forall (m :: * -> *). MonadDB m => m [Text]
getDBTableNames
  let tableNames :: [Text]
tableNames = (Table -> Text) -> [Table] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> (Table -> RawSQL ()) -> Table -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> RawSQL ()
tblName) [Table]
tables
      absent :: [Text]
absent = [Text]
dbTableNames [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
tableNames
      notPresent :: [Text]
notPresent = [Text]
tableNames [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
dbTableNames

  if (Bool -> Bool
not (Bool -> Bool) -> ([Text] -> Bool) -> [Text] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool) -> [Text] -> Bool
forall a b. (a -> b) -> a -> b
$ [Text]
absent) Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> ([Text] -> Bool) -> [Text] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool) -> [Text] -> Bool
forall a b. (a -> b) -> a -> b
$ [Text]
notPresent)
    then do
      (Text -> m ()) -> [Text] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
(<+>) Text
"Unknown table:") [Text]
absent
      (Text -> m ()) -> [Text] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
(<+>) Text
"Table not present in the database:") [Text]
notPresent
      ValidationResult -> m ValidationResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$
        Text -> [Text] -> ValidationResult
validateIsNull Text
"Unknown tables:" [Text]
absent
          ValidationResult -> ValidationResult -> ValidationResult
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> ValidationResult
validateIsNull Text
"Tables not present in the database:" [Text]
notPresent
    else ValidationResult -> m ValidationResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationResult
forall a. Monoid a => a
mempty

validateIsNull :: Text -> [Text] -> ValidationResult
validateIsNull :: Text -> [Text] -> ValidationResult
validateIsNull Text
_ [] = ValidationResult
forall a. Monoid a => a
mempty
validateIsNull Text
msg [Text]
ts = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$ Text
msg Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
ts

-- | Check that there's a 1-to-1 correspondence between the list of
-- 'Table's and what's actually in the table 'table_versions'.
checkExistenceOfVersionsForTables
  :: (MonadDB m, MonadLog m)
  => [Table]
  -> m ValidationResult
checkExistenceOfVersionsForTables :: forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkExistenceOfVersionsForTables [Table]
tables = do
  SqlSelect -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (SqlSelect -> m ()) -> SqlSelect -> m ()
forall a b. (a -> b) -> a -> b
$ SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"table_versions" (State SqlSelect () -> SqlSelect)
-> State SqlSelect () -> SqlSelect
forall a b. (a -> b) -> a -> b
$ do
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"name::text"
  ([Text]
existingTableNames :: [Text]) <- (Identity Text -> Text) -> m [Text]
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany Identity Text -> Text
forall a. Identity a -> a
runIdentity

  let tableNames :: [Text]
tableNames = (Table -> Text) -> [Table] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> (Table -> RawSQL ()) -> Table -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> RawSQL ()
tblName) [Table]
tables
      absent :: [Text]
absent = [Text]
existingTableNames [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
tableNames
      notPresent :: [Text]
notPresent = [Text]
tableNames [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
existingTableNames

  if (Bool -> Bool
not (Bool -> Bool) -> ([Text] -> Bool) -> [Text] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool) -> [Text] -> Bool
forall a b. (a -> b) -> a -> b
$ [Text]
absent) Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> ([Text] -> Bool) -> [Text] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool) -> [Text] -> Bool
forall a b. (a -> b) -> a -> b
$ [Text]
notPresent)
    then do
      (Text -> m ()) -> [Text] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
(<+>) Text
"Unknown entry in 'table_versions':") [Text]
absent
      (Text -> m ()) -> [Text] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
        (Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
(<+>) Text
"Table not present in the 'table_versions':")
        [Text]
notPresent
      ValidationResult -> m ValidationResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$
        Text -> [Text] -> ValidationResult
validateIsNull Text
"Unknown entry in table_versions':" [Text]
absent
          ValidationResult -> ValidationResult -> ValidationResult
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> ValidationResult
validateIsNull Text
"Tables not present in the 'table_versions':" [Text]
notPresent
    else ValidationResult -> m ValidationResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationResult
forall a. Monoid a => a
mempty

checkDomainsStructure
  :: (MonadDB m, MonadThrow m)
  => [Domain]
  -> m ValidationResult
checkDomainsStructure :: forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Domain] -> m ValidationResult
checkDomainsStructure [Domain]
defs = ([ValidationResult] -> ValidationResult)
-> m [ValidationResult] -> m ValidationResult
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat (m [ValidationResult] -> m ValidationResult)
-> ((Domain -> m ValidationResult) -> m [ValidationResult])
-> (Domain -> m ValidationResult)
-> m ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Domain] -> (Domain -> m ValidationResult) -> m [ValidationResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Domain]
defs ((Domain -> m ValidationResult) -> m ValidationResult)
-> (Domain -> m ValidationResult) -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ \Domain
def -> do
  SqlSelect -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (SqlSelect -> m ())
-> (State SqlSelect () -> SqlSelect) -> State SqlSelect () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_type t1" (State SqlSelect () -> m ()) -> State SqlSelect () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"t1.typname::text" -- name
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult
      SQL
"(SELECT pg_catalog.format_type(t2.oid, t2.typtypmod) \
      \FROM pg_catalog.pg_type t2 \
      \WHERE t2.oid = t1.typbasetype)" -- type
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"NOT t1.typnotnull" -- nullable
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"t1.typdefault" -- default value
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult
      SQL
"ARRAY(SELECT c.conname::text FROM pg_catalog.pg_constraint c \
      \WHERE c.contype = 'c' AND c.contypid = t1.oid \
      \ORDER by c.oid)" -- constraint names
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult
      SQL
"ARRAY(SELECT regexp_replace(pg_get_constraintdef(c.oid, true), '\
      \CHECK \\((.*)\\)', '\\1') FROM pg_catalog.pg_constraint c \
      \WHERE c.contype = 'c' AND c.contypid = t1.oid \
      \ORDER by c.oid)" -- constraint definitions
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult
      SQL
"ARRAY(SELECT c.convalidated FROM pg_catalog.pg_constraint c \
      \WHERE c.contype = 'c' AND c.contypid = t1.oid \
      \ORDER by c.oid)" -- are constraints validated?
    SQL -> Text -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"t1.typname" (Text -> State SqlSelect ()) -> Text -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> RawSQL () -> Text
forall a b. (a -> b) -> a -> b
$ Domain -> RawSQL ()
domName Domain
def
  Maybe Domain
mdom <- ((String, ColumnType, Bool, Maybe String, Array1 String,
  Array1 String, Array1 Bool)
 -> Domain)
-> m (Maybe Domain)
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m (Maybe t)
fetchMaybe (((String, ColumnType, Bool, Maybe String, Array1 String,
   Array1 String, Array1 Bool)
  -> Domain)
 -> m (Maybe Domain))
-> ((String, ColumnType, Bool, Maybe String, Array1 String,
     Array1 String, Array1 Bool)
    -> Domain)
-> m (Maybe Domain)
forall a b. (a -> b) -> a -> b
$
    \(String
dname, ColumnType
dtype, Bool
nullable, Maybe String
defval, Array1 String
cnames, Array1 String
conds, Array1 Bool
valids) ->
      Domain
        { domName :: RawSQL ()
domName = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
dname
        , domType :: ColumnType
domType = ColumnType
dtype
        , domNullable :: Bool
domNullable = Bool
nullable
        , domDefault :: Maybe (RawSQL ())
domDefault = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL (String -> RawSQL ()) -> Maybe String -> Maybe (RawSQL ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
defval
        , domChecks :: Set Check
domChecks =
            [Check] -> Set Check
mkChecks ([Check] -> Set Check) -> [Check] -> Set Check
forall a b. (a -> b) -> a -> b
$
              (String -> String -> Bool -> Check)
-> [String] -> [String] -> [Bool] -> [Check]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3
                ( \String
cname String
cond Bool
validated ->
                    Check
                      { chkName :: RawSQL ()
chkName = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
cname
                      , chkCondition :: RawSQL ()
chkCondition = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
cond
                      , chkValidated :: Bool
chkValidated = Bool
validated
                      }
                )
                (Array1 String -> [String]
forall a. Array1 a -> [a]
unArray1 Array1 String
cnames)
                (Array1 String -> [String]
forall a. Array1 a -> [a]
unArray1 Array1 String
conds)
                (Array1 Bool -> [Bool]
forall a. Array1 a -> [a]
unArray1 Array1 Bool
valids)
        }
  ValidationResult -> m ValidationResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ case Maybe Domain
mdom of
    Just Domain
dom
      | Domain
dom Domain -> Domain -> Bool
forall a. Eq a => a -> a -> Bool
/= Domain
def ->
          Text -> Text -> ValidationResult -> ValidationResult
topMessage Text
"domain" (RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> RawSQL () -> Text
forall a b. (a -> b) -> a -> b
$ Domain -> RawSQL ()
domName Domain
dom) (ValidationResult -> ValidationResult)
-> ValidationResult -> ValidationResult
forall a b. (a -> b) -> a -> b
$
            [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat
              [ Domain
-> Domain -> Text -> (Domain -> RawSQL ()) -> ValidationResult
forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"name" Domain -> RawSQL ()
domName
              , Domain
-> Domain -> Text -> (Domain -> ColumnType) -> ValidationResult
forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"type" Domain -> ColumnType
domType
              , Domain -> Domain -> Text -> (Domain -> Bool) -> ValidationResult
forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"nullable" Domain -> Bool
domNullable
              , Domain
-> Domain
-> Text
-> (Domain -> Maybe (RawSQL ()))
-> ValidationResult
forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"default" Domain -> Maybe (RawSQL ())
domDefault
              , Domain
-> Domain -> Text -> (Domain -> Set Check) -> ValidationResult
forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"checks" Domain -> Set Check
domChecks
              ]
      | Bool
otherwise -> ValidationResult
forall a. Monoid a => a
mempty
    Maybe Domain
Nothing ->
      Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
        Text
"Domain '"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RawSQL () -> Text
unRawSQL (Domain -> RawSQL ()
domName Domain
def)
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' doesn't exist in the database"
  where
    compareAttr
      :: (Eq a, Show a)
      => Domain
      -> Domain
      -> Text
      -> (Domain -> a)
      -> ValidationResult
    compareAttr :: forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
attrname Domain -> a
attr
      | Domain -> a
attr Domain
dom a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Domain -> a
attr Domain
def = ValidationResult
forall a. Monoid a => a
mempty
      | Bool
otherwise =
          Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
            Text
"Attribute '"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrname
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' does not match (database:"
              Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> String -> Text
T.pack (a -> String
forall a. Show a => a -> String
show (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ Domain -> a
attr Domain
dom)
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", definition:"
              Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> String -> Text
T.pack (a -> String
forall a. Show a => a -> String
show (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ Domain -> a
attr Domain
def)
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

checkEnumTypes
  :: (MonadDB m, MonadThrow m)
  => [EnumType]
  -> m ValidationResult
checkEnumTypes :: forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[EnumType] -> m ValidationResult
checkEnumTypes [EnumType]
defs = ([ValidationResult] -> ValidationResult)
-> m [ValidationResult] -> m ValidationResult
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat (m [ValidationResult] -> m ValidationResult)
-> ((EnumType -> m ValidationResult) -> m [ValidationResult])
-> (EnumType -> m ValidationResult)
-> m ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EnumType]
-> (EnumType -> m ValidationResult) -> m [ValidationResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [EnumType]
defs ((EnumType -> m ValidationResult) -> m ValidationResult)
-> (EnumType -> m ValidationResult) -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ \EnumType
defEnum -> do
  SqlSelect -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (SqlSelect -> m ())
-> (State SqlSelect () -> SqlSelect) -> State SqlSelect () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_type t" (State SqlSelect () -> m ()) -> State SqlSelect () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"t.typname::text" -- name
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult
      SQL
"ARRAY(SELECT e.enumlabel::text FROM pg_catalog.pg_enum e WHERE e.enumtypid = t.oid ORDER BY e.enumsortorder)" -- values
    SQL -> Text -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"t.typname" (Text -> State SqlSelect ()) -> Text -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> RawSQL () -> Text
forall a b. (a -> b) -> a -> b
$ EnumType -> RawSQL ()
etName EnumType
defEnum
  Maybe EnumType
enum <- ((String, Array1 String) -> EnumType) -> m (Maybe EnumType)
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m (Maybe t)
fetchMaybe (((String, Array1 String) -> EnumType) -> m (Maybe EnumType))
-> ((String, Array1 String) -> EnumType) -> m (Maybe EnumType)
forall a b. (a -> b) -> a -> b
$
    \(String
enumName, Array1 String
enumValues) ->
      EnumType
        { etName :: RawSQL ()
etName = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
enumName
        , etValues :: [RawSQL ()]
etValues = (String -> RawSQL ()) -> [String] -> [RawSQL ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL ([String] -> [RawSQL ()]) -> [String] -> [RawSQL ()]
forall a b. (a -> b) -> a -> b
$ Array1 String -> [String]
forall a. Array1 a -> [a]
unArray1 Array1 String
enumValues
        }
  ValidationResult -> m ValidationResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ case Maybe EnumType
enum of
    Just EnumType
dbEnum -> do
      let enumName :: Text
enumName = RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> RawSQL () -> Text
forall a b. (a -> b) -> a -> b
$ EnumType -> RawSQL ()
etName EnumType
defEnum
          dbValues :: [Text]
dbValues = (RawSQL () -> Text) -> [RawSQL ()] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map RawSQL () -> Text
unRawSQL ([RawSQL ()] -> [Text]) -> [RawSQL ()] -> [Text]
forall a b. (a -> b) -> a -> b
$ EnumType -> [RawSQL ()]
etValues EnumType
dbEnum
          defValues :: [Text]
defValues = (RawSQL () -> Text) -> [RawSQL ()] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map RawSQL () -> Text
unRawSQL ([RawSQL ()] -> [Text]) -> [RawSQL ()] -> [Text]
forall a b. (a -> b) -> a -> b
$ EnumType -> [RawSQL ()]
etValues EnumType
defEnum
          dbSet :: Set Text
dbSet = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList [Text]
dbValues
          defSet :: Set Text
defSet = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList [Text]
defValues
      if
        | [Text]
dbValues [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text]
defValues -> ValidationResult
forall a. Monoid a => a
mempty
        | [Text] -> [Text]
forall a. Ord a => [a] -> [a]
L.sort [Text]
dbValues [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text] -> [Text]
forall a. Ord a => [a] -> [a]
L.sort [Text]
defValues ->
            Text -> ValidationResult
validationInfo (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
              Text
"Enum '"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
enumName
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' has same values, but differs in order (database: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([Text] -> String
forall a. Show a => a -> String
show [Text]
dbValues)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", definition: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([Text] -> String
forall a. Show a => a -> String
show [Text]
defValues)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"). "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"This isn't usually a problem, unless the enum is used for ordering."
        | Set Text -> Set Text -> Bool
forall a. Ord a => Set a -> Set a -> Bool
S.isSubsetOf Set Text
defSet Set Text
dbSet ->
            Text -> ValidationResult
validationInfo (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
              Text
"Enum '"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
enumName
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' has all necessary values, but the database has additional ones "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(database: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([Text] -> String
forall a. Show a => a -> String
show [Text]
dbValues)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", definition: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([Text] -> String
forall a. Show a => a -> String
show [Text]
defValues)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
        | Bool
otherwise ->
            Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
              Text
"Enum '"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
enumName
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' does not match (database: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([Text] -> String
forall a. Show a => a -> String
show [Text]
dbValues)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", definition: "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([Text] -> String
forall a. Show a => a -> String
show [Text]
defValues)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    Maybe EnumType
Nothing ->
      Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
        Text
"Enum '"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RawSQL () -> Text
unRawSQL (EnumType -> RawSQL ()
etName EnumType
defEnum)
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' doesn't exist in the database"

-- | Check that the tables that must have been dropped are actually
-- missing from the DB.
checkTablesWereDropped
  :: (MonadDB m, MonadThrow m)
  => [Migration m]
  -> m ValidationResult
checkTablesWereDropped :: forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Migration m] -> m ValidationResult
checkTablesWereDropped [Migration m]
mgrs = do
  let droppedTableNames :: [RawSQL ()]
droppedTableNames =
        [ Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr
        | Migration m
mgr <- [Migration m]
mgrs
        , Migration m -> Bool
forall (m :: * -> *). Migration m -> Bool
isDropTableMigration Migration m
mgr
        ]
  ([ValidationResult] -> ValidationResult)
-> m [ValidationResult] -> m ValidationResult
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat (m [ValidationResult] -> m ValidationResult)
-> ((RawSQL () -> m ValidationResult) -> m [ValidationResult])
-> (RawSQL () -> m ValidationResult)
-> m ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RawSQL ()]
-> (RawSQL () -> m ValidationResult) -> m [ValidationResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [RawSQL ()]
droppedTableNames ((RawSQL () -> m ValidationResult) -> m ValidationResult)
-> (RawSQL () -> m ValidationResult) -> m ValidationResult
forall a b. (a -> b) -> a -> b
$
    \RawSQL ()
tblName -> do
      Maybe Int32
mver <- String -> m (Maybe Int32)
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
String -> m (Maybe Int32)
checkTableVersion (Text -> String
T.unpack (Text -> String) -> (RawSQL () -> Text) -> RawSQL () -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL (RawSQL () -> String) -> RawSQL () -> String
forall a b. (a -> b) -> a -> b
$ RawSQL ()
tblName)
      ValidationResult -> m ValidationResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$
        if Maybe Int32 -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int32
mver
          then ValidationResult
forall a. Monoid a => a
mempty
          else
            Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
              Text
"The table '"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RawSQL () -> Text
unRawSQL RawSQL ()
tblName
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' that must have been dropped"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is still present in the database."

data CompositesCreationMode
  = CreateCompositesIfDatabaseEmpty
  | DontCreateComposites
  deriving (CompositesCreationMode -> CompositesCreationMode -> Bool
(CompositesCreationMode -> CompositesCreationMode -> Bool)
-> (CompositesCreationMode -> CompositesCreationMode -> Bool)
-> Eq CompositesCreationMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CompositesCreationMode -> CompositesCreationMode -> Bool
== :: CompositesCreationMode -> CompositesCreationMode -> Bool
$c/= :: CompositesCreationMode -> CompositesCreationMode -> Bool
/= :: CompositesCreationMode -> CompositesCreationMode -> Bool
Eq)

-- | Check that there is 1 to 1 correspondence between composite types in the
-- database and the list of their code definitions.
checkCompositesStructure
  :: MonadDB m
  => TablesWithVersions
  -> CompositesCreationMode
  -> ObjectsValidationMode
  -> [CompositeType]
  -> m ValidationResult
checkCompositesStructure :: forall (m :: * -> *).
MonadDB m =>
TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> m ValidationResult
checkCompositesStructure TablesWithVersions
tablesWithVersions CompositesCreationMode
ccm ObjectsValidationMode
ovm [CompositeType]
compositeList =
  m [CompositeType]
forall (m :: * -> *). MonadDB m => m [CompositeType]
getDBCompositeTypes m [CompositeType]
-> ([CompositeType] -> m ValidationResult) -> m ValidationResult
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [] | TablesWithVersions -> Bool
noTablesPresent TablesWithVersions
tablesWithVersions Bool -> Bool -> Bool
&& CompositesCreationMode
ccm CompositesCreationMode -> CompositesCreationMode -> Bool
forall a. Eq a => a -> a -> Bool
== CompositesCreationMode
CreateCompositesIfDatabaseEmpty -> do
      -- DB is not initialized, create composites if there are any defined.
      (CompositeType -> m ()) -> [CompositeType] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (RawSQL () -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (RawSQL () -> m ())
-> (CompositeType -> RawSQL ()) -> CompositeType -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeType -> RawSQL ()
sqlCreateComposite) [CompositeType]
compositeList
      ValidationResult -> m ValidationResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationResult
forall a. Monoid a => a
mempty
    [CompositeType]
dbCompositeTypes ->
      ValidationResult -> m ValidationResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$
        [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat
          [ ValidationResult
checkNotPresentComposites
          , ValidationResult
checkDatabaseComposites
          ]
      where
        compositeMap :: Map Text [CompositeColumn]
compositeMap =
          [(Text, [CompositeColumn])] -> Map Text [CompositeColumn]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, [CompositeColumn])] -> Map Text [CompositeColumn])
-> [(Text, [CompositeColumn])] -> Map Text [CompositeColumn]
forall a b. (a -> b) -> a -> b
$
            (CompositeType -> (Text, [CompositeColumn]))
-> [CompositeType] -> [(Text, [CompositeColumn])]
forall a b. (a -> b) -> [a] -> [b]
map ((RawSQL () -> Text
unRawSQL (RawSQL () -> Text)
-> (CompositeType -> RawSQL ()) -> CompositeType -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeType -> RawSQL ()
ctName) (CompositeType -> Text)
-> (CompositeType -> [CompositeColumn])
-> CompositeType
-> (Text, [CompositeColumn])
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& CompositeType -> [CompositeColumn]
ctColumns) [CompositeType]
compositeList

        checkNotPresentComposites :: ValidationResult
checkNotPresentComposites =
          let notPresent :: [Text]
notPresent =
                Set Text -> [Text]
forall a. Set a -> [a]
S.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$
                  Map Text [CompositeColumn] -> Set Text
forall k a. Map k a -> Set k
M.keysSet Map Text [CompositeColumn]
compositeMap
                    Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
S.\\ [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ((CompositeType -> Text) -> [CompositeType] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (RawSQL () -> Text
unRawSQL (RawSQL () -> Text)
-> (CompositeType -> RawSQL ()) -> CompositeType -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeType -> RawSQL ()
ctName) [CompositeType]
dbCompositeTypes)
          in Text -> [Text] -> ValidationResult
validateIsNull Text
"Composite types not present in the database:" [Text]
notPresent

        checkDatabaseComposites :: ValidationResult
checkDatabaseComposites = [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat ([ValidationResult] -> ValidationResult)
-> ((CompositeType -> ValidationResult) -> [ValidationResult])
-> (CompositeType -> ValidationResult)
-> ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CompositeType -> ValidationResult)
-> [CompositeType] -> [ValidationResult]
forall a b. (a -> b) -> [a] -> [b]
`map` [CompositeType]
dbCompositeTypes) ((CompositeType -> ValidationResult) -> ValidationResult)
-> (CompositeType -> ValidationResult) -> ValidationResult
forall a b. (a -> b) -> a -> b
$ \CompositeType
dbComposite ->
          let cname :: Text
cname = RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> RawSQL () -> Text
forall a b. (a -> b) -> a -> b
$ CompositeType -> RawSQL ()
ctName CompositeType
dbComposite
          in case Text
cname Text -> Map Text [CompositeColumn] -> Maybe [CompositeColumn]
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Text [CompositeColumn]
compositeMap of
              Just [CompositeColumn]
columns ->
                Text -> Text -> ValidationResult -> ValidationResult
topMessage Text
"composite type" Text
cname (ValidationResult -> ValidationResult)
-> ValidationResult -> ValidationResult
forall a b. (a -> b) -> a -> b
$
                  Int -> [CompositeColumn] -> [CompositeColumn] -> ValidationResult
checkColumns Int
1 [CompositeColumn]
columns (CompositeType -> [CompositeColumn]
ctColumns CompositeType
dbComposite)
              Maybe [CompositeColumn]
Nothing -> case ObjectsValidationMode
ovm of
                ObjectsValidationMode
AllowUnknownObjects -> ValidationResult
forall a. Monoid a => a
mempty
                ObjectsValidationMode
DontAllowUnknownObjects ->
                  Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
                    [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                      [ Text
"Composite type '"
                      , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ CompositeType -> String
forall a. Show a => a -> String
show CompositeType
dbComposite
                      , Text
"' from the database doesn't have a corresponding code definition"
                      ]
          where
            checkColumns
              :: Int -> [CompositeColumn] -> [CompositeColumn] -> ValidationResult
            checkColumns :: Int -> [CompositeColumn] -> [CompositeColumn] -> ValidationResult
checkColumns Int
_ [] [] = ValidationResult
forall a. Monoid a => a
mempty
            checkColumns Int
_ [CompositeColumn]
rest [] =
              Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
                Text -> Text -> [CompositeColumn] -> Text
forall t. Show t => Text -> Text -> t -> Text
objectHasLess Text
"Composite type" Text
"columns" [CompositeColumn]
rest
            checkColumns Int
_ [] [CompositeColumn]
rest =
              Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
                Text -> Text -> [CompositeColumn] -> Text
forall t. Show t => Text -> Text -> t -> Text
objectHasMore Text
"Composite type" Text
"columns" [CompositeColumn]
rest
            checkColumns !Int
n (CompositeColumn
d : [CompositeColumn]
defs) (CompositeColumn
c : [CompositeColumn]
cols) =
              [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat
                [ Bool -> ValidationResult
validateNames (Bool -> ValidationResult) -> Bool -> ValidationResult
forall a b. (a -> b) -> a -> b
$ CompositeColumn -> RawSQL ()
ccName CompositeColumn
d RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
== CompositeColumn -> RawSQL ()
ccName CompositeColumn
c
                , Bool -> ValidationResult
validateTypes (Bool -> ValidationResult) -> Bool -> ValidationResult
forall a b. (a -> b) -> a -> b
$ CompositeColumn -> ColumnType
ccType CompositeColumn
d ColumnType -> ColumnType -> Bool
forall a. Eq a => a -> a -> Bool
== CompositeColumn -> ColumnType
ccType CompositeColumn
c
                , Int -> [CompositeColumn] -> [CompositeColumn] -> ValidationResult
checkColumns (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [CompositeColumn]
defs [CompositeColumn]
cols
                ]
              where
                validateNames :: Bool -> ValidationResult
validateNames Bool
True = ValidationResult
forall a. Monoid a => a
mempty
                validateNames Bool
False =
                  Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
                    Text -> Text -> (CompositeColumn -> Text) -> Text
errorMsg (Text
"no. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
n) Text
"names" (RawSQL () -> Text
unRawSQL (RawSQL () -> Text)
-> (CompositeColumn -> RawSQL ()) -> CompositeColumn -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeColumn -> RawSQL ()
ccName)

                validateTypes :: Bool -> ValidationResult
validateTypes Bool
True = ValidationResult
forall a. Monoid a => a
mempty
                validateTypes Bool
False =
                  Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
                    Text -> Text -> (CompositeColumn -> Text) -> Text
errorMsg (RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> RawSQL () -> Text
forall a b. (a -> b) -> a -> b
$ CompositeColumn -> RawSQL ()
ccName CompositeColumn
d) Text
"types" (String -> Text
T.pack (String -> Text)
-> (CompositeColumn -> String) -> CompositeColumn -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColumnType -> String
forall a. Show a => a -> String
show (ColumnType -> String)
-> (CompositeColumn -> ColumnType) -> CompositeColumn -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeColumn -> ColumnType
ccType)

                errorMsg :: Text -> Text -> (CompositeColumn -> Text) -> Text
errorMsg Text
ident Text
attr CompositeColumn -> Text
f =
                  Text
"Column '"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ident
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' differs in"
                    Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
attr
                    Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"(database:"
                    Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> CompositeColumn -> Text
f CompositeColumn
c
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", definition:"
                    Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> CompositeColumn -> Text
f CompositeColumn
d
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")."

-- | Checks whether the database is consistent.
checkDBStructure
  :: forall m
   . (MonadDB m, MonadThrow m)
  => ExtrasOptions
  -> TablesWithVersions
  -> m ValidationResult
checkDBStructure :: forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
ExtrasOptions -> TablesWithVersions -> m ValidationResult
checkDBStructure ExtrasOptions
options TablesWithVersions
tables = ([ValidationResult] -> ValidationResult)
-> m [ValidationResult] -> m ValidationResult
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat (m [ValidationResult] -> m ValidationResult)
-> (((Table, Int32) -> m ValidationResult) -> m [ValidationResult])
-> ((Table, Int32) -> m ValidationResult)
-> m ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TablesWithVersions
-> ((Table, Int32) -> m ValidationResult) -> m [ValidationResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM TablesWithVersions
tables (((Table, Int32) -> m ValidationResult) -> m ValidationResult)
-> ((Table, Int32) -> m ValidationResult) -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ \(Table
table, Int32
version) -> do
  ValidationResult
result <- Text -> Text -> ValidationResult -> ValidationResult
topMessage Text
"table" (Table -> Text
tblNameText Table
table) (ValidationResult -> ValidationResult)
-> m ValidationResult -> m ValidationResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Table -> m ValidationResult
checkTableStructure Table
table
  -- If we allow higher table versions in the database, show inconsistencies as
  -- info messages only.
  ValidationResult -> m ValidationResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$
    if ExtrasOptions -> Bool
eoAllowHigherTableVersions ExtrasOptions
options Bool -> Bool -> Bool
&& Table -> Int32
tblVersion Table
table Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
version
      then ValidationResult -> ValidationResult
validationErrorsToInfos ValidationResult
result
      else ValidationResult
result
  where
    checkTableStructure :: Table -> m ValidationResult
    checkTableStructure :: Table -> m ValidationResult
checkTableStructure table :: Table
table@Table {Int32
[Check]
[ForeignKey]
[TableIndex]
[Trigger]
[TableColumn]
Maybe PrimaryKey
Maybe TableInitialSetup
RawSQL ()
tblInitialSetup :: Table -> 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]
tblName :: RawSQL ()
tblVersion :: Int32
tblColumns :: [TableColumn]
tblPrimaryKey :: Maybe PrimaryKey
tblChecks :: [Check]
tblForeignKeys :: [ForeignKey]
tblIndexes :: [TableIndex]
tblTriggers :: [Trigger]
tblInitialSetup :: Maybe TableInitialSetup
..} = do
      -- get table description from pg_catalog as describeTable
      -- mechanism from HDBC doesn't give accurate results
      SqlSelect -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (SqlSelect -> m ()) -> SqlSelect -> m ()
forall a b. (a -> b) -> a -> b
$ SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_attribute a" (State SqlSelect () -> SqlSelect)
-> State SqlSelect () -> SqlSelect
forall a b. (a -> b) -> a -> b
$ do
        SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"a.attname::text"
        SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pg_catalog.format_type(a.atttypid, a.atttypmod)"
        SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult (SQL -> State SqlSelect ())
-> (SqlSelect -> SQL) -> SqlSelect -> State SqlSelect ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> SQL
parenthesize (SQL -> SQL) -> (SqlSelect -> SQL) -> SqlSelect -> SQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlSelect -> SQL
forall a. Sqlable a => a -> SQL
toSQLCommand (SqlSelect -> State SqlSelect ())
-> SqlSelect -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$
          SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_collation c, pg_catalog.pg_type t" (State SqlSelect () -> SqlSelect)
-> State SqlSelect () -> SqlSelect
forall a b. (a -> b) -> a -> b
$ do
            SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.collname::text"
            -- `typcollation` specifies the default collation of the type (if
            -- any), and `attcollation` is the collation of the column.
            SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"c.oid = a.attcollation AND t.oid = a.atttypid AND a.attcollation <> t.typcollation"
        SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"NOT a.attnotnull"
        SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult (SQL -> State SqlSelect ())
-> (SqlSelect -> SQL) -> SqlSelect -> State SqlSelect ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> SQL
parenthesize (SQL -> SQL) -> (SqlSelect -> SQL) -> SqlSelect -> SQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlSelect -> SQL
forall a. Sqlable a => a -> SQL
toSQLCommand (SqlSelect -> State SqlSelect ())
-> SqlSelect -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$
          SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_attrdef d" (State SqlSelect () -> SqlSelect)
-> State SqlSelect () -> SqlSelect
forall a b. (a -> b) -> a -> b
$ do
            SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pg_catalog.pg_get_expr(d.adbin, d.adrelid)"
            SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"d.adrelid = a.attrelid"
            SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"d.adnum = a.attnum"
            SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"a.atthasdef"
        SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"a.attnum > 0"
        SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"NOT a.attisdropped"
        SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"a.attrelid" (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
        SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlOrderBy v) =>
SQL -> m ()
sqlOrderBy SQL
"a.attnum"
      [TableColumn]
desc <- ((String, ColumnType, Maybe Text, Bool, Maybe String)
 -> TableColumn)
-> m [TableColumn]
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, ColumnType, Maybe Text, Bool, Maybe String) -> TableColumn
fetchTableColumn

      Bool
isAbove15 <- m Bool
forall (m :: * -> *). (MonadDB m, MonadThrow m) => m Bool
checkVersionIsAtLeast15
      -- get info about constraints from pg_catalog
      Maybe (PrimaryKey, RawSQL ())
pk <- Table -> m (Maybe (PrimaryKey, RawSQL ()))
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
Table -> m (Maybe (PrimaryKey, RawSQL ()))
sqlGetPrimaryKey Table
table
      SQL -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (SQL -> m ()) -> SQL -> m ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetChecks Table
table
      [Check]
checks <- ((String, String, Bool) -> Check) -> m [Check]
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, String, Bool) -> Check
fetchTableCheck
      SQL -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (SQL -> m ()) -> SQL -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> Table -> SQL
sqlGetIndexes Bool
isAbove15 Table
table
      [(TableIndex, RawSQL ())]
indexes <- ((String, Array1 String, Array1 String, String, Bool, Bool, Bool,
  Maybe String)
 -> (TableIndex, RawSQL ()))
-> m [(TableIndex, RawSQL ())]
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, Array1 String, Array1 String, String, Bool, Bool, Bool,
 Maybe String)
-> (TableIndex, RawSQL ())
fetchTableIndex
      SQL -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (SQL -> m ()) -> SQL -> m ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetForeignKeys Table
table
      [(ForeignKey, RawSQL ())]
fkeys <- ((String, Array1 String, String, Array1 String, Char, Char, Bool,
  Bool, Bool)
 -> (ForeignKey, RawSQL ()))
-> m [(ForeignKey, RawSQL ())]
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, Array1 String, String, Array1 String, Char, Char, Bool,
 Bool, Bool)
-> (ForeignKey, RawSQL ())
fetchForeignKey
      [(Trigger, RawSQL ())]
triggers <- RawSQL () -> m [(Trigger, RawSQL ())]
forall (m :: * -> *).
MonadDB m =>
RawSQL () -> m [(Trigger, RawSQL ())]
getDBTriggers RawSQL ()
tblName
      ValidationResult
checkedOverlaps <- RawSQL () -> m ValidationResult
MonadDB m => RawSQL () -> m ValidationResult
checkOverlappingIndexes RawSQL ()
tblName
      ValidationResult -> m ValidationResult
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$
        [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat
          [ Int -> [TableColumn] -> [TableColumn] -> ValidationResult
checkColumns Int
1 [TableColumn]
tblColumns [TableColumn]
desc
          , Maybe PrimaryKey
-> Maybe (PrimaryKey, RawSQL ()) -> ValidationResult
checkPrimaryKey Maybe PrimaryKey
tblPrimaryKey Maybe (PrimaryKey, RawSQL ())
pk
          , [Check] -> [Check] -> ValidationResult
checkChecks [Check]
tblChecks [Check]
checks
          , [TableIndex] -> [(TableIndex, RawSQL ())] -> ValidationResult
checkIndexes [TableIndex]
tblIndexes [(TableIndex, RawSQL ())]
indexes
          , [ForeignKey] -> [(ForeignKey, RawSQL ())] -> ValidationResult
checkForeignKeys [ForeignKey]
tblForeignKeys [(ForeignKey, RawSQL ())]
fkeys
          , Maybe PrimaryKey
-> [ForeignKey] -> [TableIndex] -> ValidationResult
checkForeignKeyIndexes Maybe PrimaryKey
tblPrimaryKey [ForeignKey]
tblForeignKeys [TableIndex]
tblIndexes
          , [Trigger] -> [(Trigger, RawSQL ())] -> ValidationResult
checkTriggers [Trigger]
tblTriggers [(Trigger, RawSQL ())]
triggers
          , ValidationResult
checkedOverlaps
          ]
      where
        fetchTableColumn
          :: (String, ColumnType, Maybe Text, Bool, Maybe String) -> TableColumn
        fetchTableColumn :: (String, ColumnType, Maybe Text, Bool, Maybe String) -> TableColumn
fetchTableColumn (String
name, ColumnType
ctype, Maybe Text
collation, Bool
nullable, Maybe String
mdefault) =
          TableColumn
            { colName :: RawSQL ()
colName = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name
            , colType :: ColumnType
colType = ColumnType
ctype
            , colCollation :: Maybe (RawSQL ())
colCollation = (Text -> () -> RawSQL ()) -> () -> Text -> RawSQL ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> () -> RawSQL ()
forall row. (Show row, ToRow row) => Text -> row -> RawSQL row
rawSQL () (Text -> RawSQL ()) -> Maybe Text -> Maybe (RawSQL ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
collation
            , colNullable :: Bool
colNullable = Bool
nullable
            , colDefault :: Maybe (RawSQL ())
colDefault = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL (String -> RawSQL ()) -> Maybe String -> Maybe (RawSQL ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
mdefault
            }

        checkColumns
          :: Int -> [TableColumn] -> [TableColumn] -> ValidationResult
        checkColumns :: Int -> [TableColumn] -> [TableColumn] -> ValidationResult
checkColumns Int
_ [] [] = ValidationResult
forall a. Monoid a => a
mempty
        checkColumns Int
_ [TableColumn]
rest [] =
          Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
            Text -> Text -> [TableColumn] -> Text
forall t. Show t => Text -> Text -> t -> Text
objectHasLess Text
"Table" Text
"columns" [TableColumn]
rest
        checkColumns Int
_ [] [TableColumn]
rest =
          Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
            Text -> Text -> [TableColumn] -> Text
forall t. Show t => Text -> Text -> t -> Text
objectHasMore Text
"Table" Text
"columns" [TableColumn]
rest
        checkColumns !Int
n (TableColumn
d : [TableColumn]
defs) (TableColumn
c : [TableColumn]
cols) =
          [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat
            [ Bool -> ValidationResult
validateNames (Bool -> ValidationResult) -> Bool -> ValidationResult
forall a b. (a -> b) -> a -> b
$ TableColumn -> RawSQL ()
colName TableColumn
d RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
== TableColumn -> RawSQL ()
colName TableColumn
c
            , -- bigserial == bigint + autoincrement and there is no
              -- distinction between them after table is created.
              Bool -> ValidationResult
validateTypes (Bool -> ValidationResult) -> Bool -> ValidationResult
forall a b. (a -> b) -> a -> b
$
                TableColumn -> ColumnType
colType TableColumn
d ColumnType -> ColumnType -> Bool
forall a. Eq a => a -> a -> Bool
== TableColumn -> ColumnType
colType TableColumn
c
                  Bool -> Bool -> Bool
|| (TableColumn -> ColumnType
colType TableColumn
d ColumnType -> ColumnType -> Bool
forall a. Eq a => a -> a -> Bool
== ColumnType
BigSerialT Bool -> Bool -> Bool
&& TableColumn -> ColumnType
colType TableColumn
c ColumnType -> ColumnType -> Bool
forall a. Eq a => a -> a -> Bool
== ColumnType
BigIntT)
            , -- There is a problem with default values determined by
              -- sequences as they're implicitly specified by db, so
              -- let's omit them in such case.
              Bool -> ValidationResult
validateDefaults (Bool -> ValidationResult) -> Bool -> ValidationResult
forall a b. (a -> b) -> a -> b
$
                TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
d Maybe (RawSQL ()) -> Maybe (RawSQL ()) -> Bool
forall a. Eq a => a -> a -> Bool
== TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
c
                  Bool -> Bool -> Bool
|| ( Maybe (RawSQL ()) -> Bool
forall a. Maybe a -> Bool
isNothing (TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
d)
                        Bool -> Bool -> Bool
&& (Text -> Text -> Bool
T.isPrefixOf Text
"nextval('" (Text -> Bool) -> (RawSQL () -> Text) -> RawSQL () -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL (RawSQL () -> Bool) -> Maybe (RawSQL ()) -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
c)
                          Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
                     )
            , Bool -> ValidationResult
validateNullables (Bool -> ValidationResult) -> Bool -> ValidationResult
forall a b. (a -> b) -> a -> b
$ TableColumn -> Bool
colNullable TableColumn
d Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== TableColumn -> Bool
colNullable TableColumn
c
            , Int -> [TableColumn] -> [TableColumn] -> ValidationResult
checkColumns (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [TableColumn]
defs [TableColumn]
cols
            ]
          where
            validateNames :: Bool -> ValidationResult
validateNames Bool
True = ValidationResult
forall a. Monoid a => a
mempty
            validateNames Bool
False =
              Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
                Text -> Text -> (TableColumn -> Text) -> Text
errorMsg (Text
"no. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
n) Text
"names" (RawSQL () -> Text
unRawSQL (RawSQL () -> Text)
-> (TableColumn -> RawSQL ()) -> TableColumn -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableColumn -> RawSQL ()
colName)

            validateTypes :: Bool -> ValidationResult
validateTypes Bool
True = ValidationResult
forall a. Monoid a => a
mempty
            validateTypes Bool
False =
              Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
                Text -> Text -> (TableColumn -> Text) -> Text
errorMsg Text
cname Text
"types" (String -> Text
T.pack (String -> Text) -> (TableColumn -> String) -> TableColumn -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColumnType -> String
forall a. Show a => a -> String
show (ColumnType -> String)
-> (TableColumn -> ColumnType) -> TableColumn -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableColumn -> ColumnType
colType)
                  Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
sqlHint (RawSQL ()
"TYPE" RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> ColumnType -> RawSQL ()
columnTypeToSQL (TableColumn -> ColumnType
colType TableColumn
d))

            validateNullables :: Bool -> ValidationResult
validateNullables Bool
True = ValidationResult
forall a. Monoid a => a
mempty
            validateNullables Bool
False =
              Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
                Text -> Text -> (TableColumn -> Text) -> Text
errorMsg Text
cname Text
"nullables" (Bool -> Text
forall a. TextShow a => a -> Text
showt (Bool -> Text) -> (TableColumn -> Bool) -> TableColumn -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableColumn -> Bool
colNullable)
                  Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
sqlHint
                    ( (if TableColumn -> Bool
colNullable TableColumn
d then RawSQL ()
"DROP" else RawSQL ()
"SET")
                        RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"NOT NULL"
                    )

            validateDefaults :: Bool -> ValidationResult
validateDefaults Bool
True = ValidationResult
forall a. Monoid a => a
mempty
            validateDefaults Bool
False =
              Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
                Text -> Text -> (TableColumn -> Text) -> Text
errorMsg Text
cname Text
"defaults" (Maybe Text -> Text
forall a. TextShow a => a -> Text
showt (Maybe Text -> Text)
-> (TableColumn -> Maybe Text) -> TableColumn -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RawSQL () -> Text) -> Maybe (RawSQL ()) -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RawSQL () -> Text
unRawSQL (Maybe (RawSQL ()) -> Maybe Text)
-> (TableColumn -> Maybe (RawSQL ())) -> TableColumn -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableColumn -> Maybe (RawSQL ())
colDefault)
                  Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
sqlHint RawSQL ()
set_default
              where
                set_default :: RawSQL ()
set_default = case TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
d of
                  Just RawSQL ()
v -> RawSQL ()
"SET DEFAULT" RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
v
                  Maybe (RawSQL ())
Nothing -> RawSQL ()
"DROP DEFAULT"

            cname :: Text
cname = RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> RawSQL () -> Text
forall a b. (a -> b) -> a -> b
$ TableColumn -> RawSQL ()
colName TableColumn
d
            errorMsg :: Text -> Text -> (TableColumn -> Text) -> Text
errorMsg Text
ident Text
attr TableColumn -> Text
f =
              Text
"Column '"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ident
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' differs in"
                Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
attr
                Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"(table:"
                Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> TableColumn -> Text
f TableColumn
c
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", definition:"
                Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> TableColumn -> Text
f TableColumn
d
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")."
            sqlHint :: RawSQL () -> Text
sqlHint RawSQL ()
sql =
              Text
"(HINT: SQL for making the change is: ALTER TABLE"
                Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Table -> Text
tblNameText Table
table
                Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"ALTER COLUMN"
                Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
unRawSQL (TableColumn -> RawSQL ()
colName TableColumn
d)
                Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
unRawSQL RawSQL ()
sql
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

        checkPrimaryKey
          :: Maybe PrimaryKey
          -> Maybe (PrimaryKey, RawSQL ())
          -> ValidationResult
        checkPrimaryKey :: Maybe PrimaryKey
-> Maybe (PrimaryKey, RawSQL ()) -> ValidationResult
checkPrimaryKey Maybe PrimaryKey
mdef Maybe (PrimaryKey, RawSQL ())
mpk =
          [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat
            [ Text -> [PrimaryKey] -> [PrimaryKey] -> ValidationResult
forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"PRIMARY KEY" [PrimaryKey]
def (((PrimaryKey, RawSQL ()) -> PrimaryKey)
-> [(PrimaryKey, RawSQL ())] -> [PrimaryKey]
forall a b. (a -> b) -> [a] -> [b]
map (PrimaryKey, RawSQL ()) -> PrimaryKey
forall a b. (a, b) -> a
fst [(PrimaryKey, RawSQL ())]
pk)
            , (PrimaryKey -> RawSQL ())
-> [(PrimaryKey, RawSQL ())] -> ValidationResult
forall t.
Show t =>
(t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
checkNames (RawSQL () -> PrimaryKey -> RawSQL ()
forall a b. a -> b -> a
const (RawSQL () -> RawSQL ()
pkName RawSQL ()
tblName)) [(PrimaryKey, RawSQL ())]
pk
            , if ExtrasOptions -> Bool
eoEnforcePKs ExtrasOptions
options
                then RawSQL ()
-> Maybe PrimaryKey
-> Maybe (PrimaryKey, RawSQL ())
-> ValidationResult
checkPKPresence RawSQL ()
tblName Maybe PrimaryKey
mdef Maybe (PrimaryKey, RawSQL ())
mpk
                else ValidationResult
forall a. Monoid a => a
mempty
            ]
          where
            def :: [PrimaryKey]
def = Maybe PrimaryKey -> [PrimaryKey]
forall a. Maybe a -> [a]
maybeToList Maybe PrimaryKey
mdef
            pk :: [(PrimaryKey, RawSQL ())]
pk = Maybe (PrimaryKey, RawSQL ()) -> [(PrimaryKey, RawSQL ())]
forall a. Maybe a -> [a]
maybeToList Maybe (PrimaryKey, RawSQL ())
mpk

        checkChecks :: [Check] -> [Check] -> ValidationResult
        checkChecks :: [Check] -> [Check] -> ValidationResult
checkChecks [Check]
defs [Check]
checks =
          ([Text] -> [Text])
-> ([Text] -> [Text]) -> ValidationResult -> ValidationResult
mapValidationResult [Text] -> [Text]
forall a. a -> a
id [Text] -> [Text]
forall {a}. IsString a => [a] -> [a]
mapErrs (Text -> [Check] -> [Check] -> ValidationResult
forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"CHECKs" [Check]
defs [Check]
checks)
          where
            mapErrs :: [a] -> [a]
mapErrs [] = []
            mapErrs [a]
errmsgs =
              [a]
errmsgs
                [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [ a
" (HINT: If checks are equal modulo number of \
                     \ parentheses/whitespaces used in conditions, \
                     \ just copy and paste expected output into source code)"
                   ]

        checkIndexes
          :: [TableIndex]
          -> [(TableIndex, RawSQL ())]
          -> ValidationResult
        checkIndexes :: [TableIndex] -> [(TableIndex, RawSQL ())] -> ValidationResult
checkIndexes [TableIndex]
defs [(TableIndex, RawSQL ())]
allIndexes =
          [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat ([ValidationResult] -> ValidationResult)
-> [ValidationResult] -> ValidationResult
forall a b. (a -> b) -> a -> b
$
            Text -> [TableIndex] -> [TableIndex] -> ValidationResult
forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"INDEXes" [TableIndex]
defs (((TableIndex, RawSQL ()) -> TableIndex)
-> [(TableIndex, RawSQL ())] -> [TableIndex]
forall a b. (a -> b) -> [a] -> [b]
map (TableIndex, RawSQL ()) -> TableIndex
forall a b. (a, b) -> a
fst [(TableIndex, RawSQL ())]
indexes)
              ValidationResult -> [ValidationResult] -> [ValidationResult]
forall a. a -> [a] -> [a]
: (TableIndex -> RawSQL ())
-> [(TableIndex, RawSQL ())] -> ValidationResult
forall t.
Show t =>
(t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
checkNames (RawSQL () -> TableIndex -> RawSQL ()
indexName RawSQL ()
tblName) [(TableIndex, RawSQL ())]
indexes
              ValidationResult -> [ValidationResult] -> [ValidationResult]
forall a. a -> [a] -> [a]
: ((TableIndex, RawSQL ()) -> ValidationResult)
-> [(TableIndex, RawSQL ())] -> [ValidationResult]
forall a b. (a -> b) -> [a] -> [b]
map (TableIndex, RawSQL ()) -> ValidationResult
forall {a}. Show a => (a, RawSQL ()) -> ValidationResult
localIndexInfo [(TableIndex, RawSQL ())]
localIndexes
          where
            localIndexInfo :: (a, RawSQL ()) -> ValidationResult
localIndexInfo (a
index, RawSQL ()
name) =
              Text -> ValidationResult
validationInfo (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
                [Text] -> Text
T.concat
                  [ Text
"Found a local index '"
                  , RawSQL () -> Text
unRawSQL RawSQL ()
name
                  , Text
"': "
                  , String -> Text
T.pack (a -> String
forall a. Show a => a -> String
show a
index)
                  ]

            ([(TableIndex, RawSQL ())]
localIndexes, [(TableIndex, RawSQL ())]
indexes) = (((TableIndex, RawSQL ()) -> Bool)
-> [(TableIndex, RawSQL ())]
-> ([(TableIndex, RawSQL ())], [(TableIndex, RawSQL ())])
forall a. (a -> Bool) -> [a] -> ([a], [a])
`partition` [(TableIndex, RawSQL ())]
allIndexes) (((TableIndex, RawSQL ()) -> Bool)
 -> ([(TableIndex, RawSQL ())], [(TableIndex, RawSQL ())]))
-> ((TableIndex, RawSQL ()) -> Bool)
-> ([(TableIndex, RawSQL ())], [(TableIndex, RawSQL ())])
forall a b. (a -> b) -> a -> b
$ \(TableIndex
_, RawSQL ()
name) ->
              -- Manually created indexes for ad-hoc improvements.
              Text
"local_" Text -> Text -> Bool
`T.isPrefixOf` RawSQL () -> Text
unRawSQL RawSQL ()
name
                -- Indexes related to the REINDEX operation, see
                -- https://www.postgresql.org/docs/15/sql-reindex.html
                Bool -> Bool -> Bool
|| Text
"_ccnew" Text -> Text -> Bool
`T.isSuffixOf` RawSQL () -> Text
unRawSQL RawSQL ()
name
                Bool -> Bool -> Bool
|| Text
"_ccold" Text -> Text -> Bool
`T.isSuffixOf` RawSQL () -> Text
unRawSQL RawSQL ()
name

        checkForeignKeys
          :: [ForeignKey]
          -> [(ForeignKey, RawSQL ())]
          -> ValidationResult
        checkForeignKeys :: [ForeignKey] -> [(ForeignKey, RawSQL ())] -> ValidationResult
checkForeignKeys [ForeignKey]
defs [(ForeignKey, RawSQL ())]
fkeys =
          [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat
            [ Text -> [ForeignKey] -> [ForeignKey] -> ValidationResult
forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"FOREIGN KEYs" [ForeignKey]
defs (((ForeignKey, RawSQL ()) -> ForeignKey)
-> [(ForeignKey, RawSQL ())] -> [ForeignKey]
forall a b. (a -> b) -> [a] -> [b]
map (ForeignKey, RawSQL ()) -> ForeignKey
forall a b. (a, b) -> a
fst [(ForeignKey, RawSQL ())]
fkeys)
            , (ForeignKey -> RawSQL ())
-> [(ForeignKey, RawSQL ())] -> ValidationResult
forall t.
Show t =>
(t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
checkNames (RawSQL () -> ForeignKey -> RawSQL ()
fkName RawSQL ()
tblName) [(ForeignKey, RawSQL ())]
fkeys
            ]

        checkForeignKeyIndexes :: Maybe PrimaryKey -> [ForeignKey] -> [TableIndex] -> ValidationResult
        checkForeignKeyIndexes :: Maybe PrimaryKey
-> [ForeignKey] -> [TableIndex] -> ValidationResult
checkForeignKeyIndexes Maybe PrimaryKey
pkey [ForeignKey]
foreignKeys [TableIndex]
indexes =
          if ExtrasOptions -> Bool
eoCheckForeignKeysIndexes ExtrasOptions
options
            then (ForeignKey -> ValidationResult)
-> [ForeignKey] -> ValidationResult
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' ForeignKey -> ValidationResult
go [ForeignKey]
foreignKeys
            else ValidationResult
forall a. Monoid a => a
mempty
          where
            -- Map index on the given table name to a list of list of names
            -- so that index on a and index on (b, c) becomes [[a], [b, c,]].
            allIndexes :: [[RawSQL ()]]
            allIndexes :: [[RawSQL ()]]
allIndexes = (TableIndex -> [RawSQL ()]) -> [TableIndex] -> [[RawSQL ()]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IndexColumn -> RawSQL ()) -> [IndexColumn] -> [RawSQL ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IndexColumn -> RawSQL ()
indexColumnName ([IndexColumn] -> [RawSQL ()])
-> (TableIndex -> [IndexColumn]) -> TableIndex -> [RawSQL ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableIndex -> [IndexColumn]
idxColumns) ([TableIndex] -> [[RawSQL ()]])
-> ([TableIndex] -> [TableIndex]) -> [TableIndex] -> [[RawSQL ()]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TableIndex -> Bool) -> [TableIndex] -> [TableIndex]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe (RawSQL ()) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (RawSQL ()) -> Bool)
-> (TableIndex -> Maybe (RawSQL ())) -> TableIndex -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableIndex -> Maybe (RawSQL ())
idxWhere) ([TableIndex] -> [[RawSQL ()]]) -> [TableIndex] -> [[RawSQL ()]]
forall a b. (a -> b) -> a -> b
$ [TableIndex]
indexes

            allCoverage :: [[RawSQL ()]]
            allCoverage :: [[RawSQL ()]]
allCoverage = [RawSQL ()]
-> (PrimaryKey -> [RawSQL ()]) -> Maybe PrimaryKey -> [RawSQL ()]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] PrimaryKey -> [RawSQL ()]
pkColumns Maybe PrimaryKey
pkey [RawSQL ()] -> [[RawSQL ()]] -> [[RawSQL ()]]
forall a. a -> [a] -> [a]
: [[RawSQL ()]]
allIndexes
            -- A foreign key is covered if it is a prefix of a list of indices.
            -- So a FK on a is covered by an index on (a, b) but not an index on (b, a).
            coveredFK :: ForeignKey -> [[RawSQL ()]] -> Bool
            coveredFK :: ForeignKey -> [[RawSQL ()]] -> Bool
coveredFK ForeignKey
fk = ([RawSQL ()] -> Bool) -> [[RawSQL ()]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\[RawSQL ()]
idx -> ForeignKey -> [RawSQL ()]
fkColumns ForeignKey
fk [RawSQL ()] -> [RawSQL ()] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` [RawSQL ()]
idx)

            go :: ForeignKey -> ValidationResult
            go :: ForeignKey -> ValidationResult
go ForeignKey
fk =
              let columns :: [Text]
columns = (RawSQL () -> Text) -> [RawSQL ()] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map RawSQL () -> Text
unRawSQL (ForeignKey -> [RawSQL ()]
fkColumns ForeignKey
fk)
              in if ForeignKey -> [[RawSQL ()]] -> Bool
coveredFK ForeignKey
fk [[RawSQL ()]]
allCoverage
                  then ValidationResult
forall a. Monoid a => a
mempty
                  else Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
"\n  ● Foreign key '(", Text -> [Text] -> Text
T.intercalate Text
"," [Text]
columns, Text
")' is missing an index"]

        checkTriggers :: [Trigger] -> [(Trigger, RawSQL ())] -> ValidationResult
        checkTriggers :: [Trigger] -> [(Trigger, RawSQL ())] -> ValidationResult
checkTriggers [Trigger]
defs [(Trigger, RawSQL ())]
triggers =
          ([Text] -> [Text])
-> ([Text] -> [Text]) -> ValidationResult -> ValidationResult
mapValidationResult [Text] -> [Text]
forall a. a -> a
id [Text] -> [Text]
forall {a}. IsString a => [a] -> [a]
mapErrs (ValidationResult -> ValidationResult)
-> ValidationResult -> ValidationResult
forall a b. (a -> b) -> a -> b
$ Text
-> [(Trigger, RawSQL ())]
-> [(Trigger, RawSQL ())]
-> ValidationResult
forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"TRIGGERs" [(Trigger, RawSQL ())]
defs' [(Trigger, RawSQL ())]
triggers
          where
            defs' :: [(Trigger, RawSQL ())]
defs' = (Trigger -> (Trigger, RawSQL ()))
-> [Trigger] -> [(Trigger, RawSQL ())]
forall a b. (a -> b) -> [a] -> [b]
map (\Trigger
t -> (Trigger
t, RawSQL () -> RawSQL ()
triggerFunctionMakeName (RawSQL () -> RawSQL ()) -> RawSQL () -> RawSQL ()
forall a b. (a -> b) -> a -> b
$ Trigger -> RawSQL ()
triggerName Trigger
t)) [Trigger]
defs
            mapErrs :: [a] -> [a]
mapErrs [] = []
            mapErrs [a]
errmsgs =
              [a]
errmsgs
                [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [ a
"(HINT: If WHEN clauses are equal modulo number of parentheses, whitespace, \
                     \case of variables or type casts used in conditions, just copy and paste \
                     \expected output into source code.)"
                   ]

        checkOverlappingIndexes :: MonadDB m => RawSQL () -> m ValidationResult
        checkOverlappingIndexes :: MonadDB m => RawSQL () -> m ValidationResult
checkOverlappingIndexes RawSQL ()
tableName =
          if ExtrasOptions -> Bool
eoCheckOverlappingIndexes ExtrasOptions
options
            then m ValidationResult
go
            else ValidationResult -> m ValidationResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidationResult
forall a. Monoid a => a
mempty
          where
            go :: m ValidationResult
go = do
              let handleOverlap :: (a, a) -> a
handleOverlap (a
contained, a
contains) =
                    [a] -> a
forall a. Monoid a => [a] -> a
mconcat
                      [ a
"\n  ●  Index "
                      , a
contains
                      , a
" contains index "
                      , a
contained
                      ]
              SQL -> m ()
forall (m :: * -> *). (HasCallStack, MonadDB m) => SQL -> m ()
runSQL_ (SQL -> m ()) -> SQL -> m ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> SQL
checkOverlappingIndexesQuery RawSQL ()
tableName
              [Text]
overlaps <- ((Text, Text) -> Text) -> m [Text]
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (Text, Text) -> Text
forall {a}. (Monoid a, IsString a) => (a, a) -> a
handleOverlap
              ValidationResult -> m ValidationResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$
                if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
overlaps
                  then ValidationResult
forall a. Monoid a => a
mempty
                  else Text -> ValidationResult
validationError (Text -> ValidationResult)
-> ([Text] -> Text) -> [Text] -> ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> ValidationResult) -> [Text] -> ValidationResult
forall a b. (a -> b) -> a -> b
$ Text
"Some indexes are overlapping" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
overlaps

-- | Checks whether database is consistent, performing migrations if
-- necessary. Requires all table names to be in lower case.
--
-- The migrations list must have the following properties:
--   * consecutive 'mgrFrom' numbers
--   * no duplicates
--   * all 'mgrFrom' are less than table version number of the table in
--     the 'tables' list
checkDBConsistency
  :: forall m
   . (MonadIO m, MonadDB m, MonadLog m, MonadMask m)
  => ExtrasOptions
  -> [Domain]
  -> [EnumType]
  -> TablesWithVersions
  -> [Migration m]
  -> m ()
checkDBConsistency :: forall (m :: * -> *).
(MonadIO m, MonadDB m, MonadLog m, MonadMask m) =>
ExtrasOptions
-> [Domain]
-> [EnumType]
-> TablesWithVersions
-> [Migration m]
-> m ()
checkDBConsistency ExtrasOptions
options [Domain]
domains [EnumType]
enums TablesWithVersions
tablesWithVersions [Migration m]
migrations = do
  Bool
autoTransaction <- TransactionSettings -> Bool
tsAutoTransaction (TransactionSettings -> Bool) -> m TransactionSettings -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m TransactionSettings
forall (m :: * -> *). MonadDB m => m TransactionSettings
getTransactionSettings
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
autoTransaction (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    String -> m ()
forall a. HasCallStack => String -> a
error String
"checkDBConsistency: tsAutoTransaction setting needs to be True"
  -- Check the validity of the migrations list.
  m ()
validateMigrations
  m ()
validateDropTableMigrations

  -- Load version numbers of the tables that actually exist in the DB.
  [(Text, Int32)]
dbTablesWithVersions <- m [(Text, Int32)]
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
m [(Text, Int32)]
getDBTableVersions

  if TablesWithVersions -> Bool
noTablesPresent TablesWithVersions
tablesWithVersions
    -- No tables are present, create everything from scratch.
    then do
      m ()
createDBSchema
      m ()
initializeDB

    -- Migration mode.
    else do
      -- Additional validity checks for the migrations list.
      [(RawSQL (), Int32, Int32)] -> m ()
validateMigrationsAgainstDB
        [ (Table -> RawSQL ()
tblName Table
table, Table -> Int32
tblVersion Table
table, Int32
actualVer)
        | (Table
table, Int32
actualVer) <- TablesWithVersions
tablesWithVersions
        ]
      [(Text, Int32)] -> m ()
validateDropTableMigrationsAgainstDB [(Text, Int32)]
dbTablesWithVersions
      -- Run migrations, if necessary.
      [(Text, Int32)] -> m ()
runMigrations [(Text, Int32)]
dbTablesWithVersions
  where
    tables :: [Table]
tables = ((Table, Int32) -> Table) -> TablesWithVersions -> [Table]
forall a b. (a -> b) -> [a] -> [b]
map (Table, Int32) -> Table
forall a b. (a, b) -> a
fst TablesWithVersions
tablesWithVersions

    errorInvalidMigrations :: HasCallStack => [RawSQL ()] -> a
    errorInvalidMigrations :: forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [RawSQL ()]
tblNames =
      String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
        String
"checkDBConsistency: invalid migrations for tables"
          String -> String -> String
forall m. (IsString m, Monoid m) => m -> m -> m
<+> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
", " ((RawSQL () -> String) -> [RawSQL ()] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack (Text -> String) -> (RawSQL () -> Text) -> RawSQL () -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL) [RawSQL ()]
tblNames)

    checkMigrationsListValidity :: Table -> [Int32] -> [Int32] -> m ()
    checkMigrationsListValidity :: Table -> [Int32] -> [Int32] -> m ()
checkMigrationsListValidity
      Table
table
      [Int32]
presentMigrationVersions
      [Int32]
expectedMigrationVersions = do
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Int32]
presentMigrationVersions [Int32] -> [Int32] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Int32]
expectedMigrationVersions) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          Text -> Value -> m ()
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention Text
"Migrations are invalid" (Value -> m ()) -> Value -> m ()
forall a b. (a -> b) -> a -> b
$
            [Pair] -> Value
object
              [ Key
"table" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Table -> Text
tblNameText Table
table
              , Key
"migration_versions" Key -> [Int32] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Int32]
presentMigrationVersions
              , Key
"expected_migration_versions" Key -> [Int32] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Int32]
expectedMigrationVersions
              ]
          [RawSQL ()] -> m ()
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [Table -> RawSQL ()
tblName Table
table]

    validateMigrations :: m ()
    validateMigrations :: m ()
validateMigrations = [Table] -> (Table -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Table]
tables ((Table -> m ()) -> m ()) -> (Table -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Table
table -> do
      -- FIXME: https://github.com/scrive/hpqtypes-extras/issues/73
      let presentMigrationVersions :: [Int32]
presentMigrationVersions =
            [ Int32
mgrFrom | Migration {Int32
RawSQL ()
MigrationAction m
mgrTableName :: forall (m :: * -> *). Migration m -> RawSQL ()
mgrFrom :: forall (m :: * -> *). Migration m -> Int32
mgrFrom :: Int32
mgrTableName :: RawSQL ()
mgrAction :: MigrationAction m
mgrAction :: forall (m :: * -> *). Migration m -> MigrationAction m
..} <- [Migration m]
migrations, RawSQL ()
mgrTableName RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
== Table -> RawSQL ()
tblName Table
table
            ]
          expectedMigrationVersions :: [Int32]
expectedMigrationVersions =
            [Int32] -> [Int32]
forall a. [a] -> [a]
reverse ([Int32] -> [Int32]) -> [Int32] -> [Int32]
forall a b. (a -> b) -> a -> b
$
              Int -> [Int32] -> [Int32]
forall a. Int -> [a] -> [a]
take ([Int32] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int32]
presentMigrationVersions) ([Int32] -> [Int32]) -> [Int32] -> [Int32]
forall a b. (a -> b) -> a -> b
$
                [Int32] -> [Int32]
forall a. [a] -> [a]
reverse [Int32
0 .. Table -> Int32
tblVersion Table
table Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
1]
      Table -> [Int32] -> [Int32] -> m ()
checkMigrationsListValidity
        Table
table
        [Int32]
presentMigrationVersions
        [Int32]
expectedMigrationVersions

    validateDropTableMigrations :: m ()
    validateDropTableMigrations :: m ()
validateDropTableMigrations = do
      let droppedTableNames :: [RawSQL ()]
droppedTableNames =
            [ Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr | Migration m
mgr <- [Migration m]
migrations, Migration m -> Bool
forall (m :: * -> *). Migration m -> Bool
isDropTableMigration Migration m
mgr
            ]
          tableNames :: [RawSQL ()]
tableNames =
            [Table -> RawSQL ()
tblName Table
tbl | Table
tbl <- [Table]
tables]

      -- Check that the intersection between the 'tables' list and
      -- dropped tables is empty.
      let intersection :: [RawSQL ()]
intersection = [RawSQL ()] -> [RawSQL ()] -> [RawSQL ()]
forall a. Eq a => [a] -> [a] -> [a]
L.intersect [RawSQL ()]
droppedTableNames [RawSQL ()]
tableNames
      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 ()]
intersection) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> Value -> m ()
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention
          ( Text
"The intersection between tables "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"and dropped tables is not empty"
          )
          (Value -> m ()) -> Value -> m ()
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
            [Key
"intersection" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (RawSQL () -> Text) -> [RawSQL ()] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map RawSQL () -> Text
unRawSQL [RawSQL ()]
intersection]
        [RawSQL ()] -> m ()
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations
          [ Table -> RawSQL ()
tblName Table
tbl
          | Table
tbl <- [Table]
tables
          , Table -> RawSQL ()
tblName Table
tbl RawSQL () -> [RawSQL ()] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RawSQL ()]
intersection
          ]

      -- Check that if a list of migrations for a given table has a
      -- drop table migration, it is unique and is the last migration
      -- in the list.
      let migrationsByTable :: [[Migration m]]
migrationsByTable =
            (Migration m -> Migration m -> Bool)
-> [Migration m] -> [[Migration m]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy
              (RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
(==) (RawSQL () -> RawSQL () -> Bool)
-> (Migration m -> RawSQL ()) -> Migration m -> Migration m -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName)
              [Migration m]
migrations
          dropMigrationLists :: [[Migration m]]
dropMigrationLists =
            [ [Migration m]
mgrs | [Migration m]
mgrs <- [[Migration m]]
migrationsByTable, (Migration m -> Bool) -> [Migration m] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Migration m -> Bool
forall (m :: * -> *). Migration m -> Bool
isDropTableMigration [Migration m]
mgrs
            ]
          invalidMigrationLists :: [[Migration m]]
invalidMigrationLists =
            [ [Migration m]
mgrs | [Migration m]
mgrs <- [[Migration m]]
dropMigrationLists, (Bool -> Bool
not (Bool -> Bool) -> ([Migration m] -> Bool) -> [Migration m] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Migration m -> Bool
forall (m :: * -> *). Migration m -> Bool
isDropTableMigration (Migration m -> Bool)
-> ([Migration m] -> Migration m) -> [Migration m] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Migration m] -> Migration m
forall a. HasCallStack => [a] -> a
last ([Migration m] -> Bool) -> [Migration m] -> Bool
forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrs)
                                                  Bool -> Bool -> Bool
|| ([Migration m] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Migration m] -> Int)
-> ([Migration m] -> [Migration m]) -> [Migration m] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Migration m -> Bool) -> [Migration m] -> [Migration m]
forall a. (a -> Bool) -> [a] -> [a]
filter Migration m -> Bool
forall (m :: * -> *). Migration m -> Bool
isDropTableMigration ([Migration m] -> Int) -> [Migration m] -> Int
forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrs) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
            ]

      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Migration m]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Migration m]]
invalidMigrationLists) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        let tablesWithInvalidMigrationLists :: [RawSQL ()]
tablesWithInvalidMigrationLists =
              [ Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr | [Migration m]
mgrs <- [[Migration m]]
invalidMigrationLists, let mgr :: Migration m
mgr = [Migration m] -> Migration m
forall a. HasCallStack => [a] -> a
head [Migration m]
mgrs
              ]
        Text -> Value -> m ()
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention
          ( Text
"Migration lists for some tables contain "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"either multiple drop table migrations or "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"a drop table migration in non-tail position."
          )
          (Value -> m ()) -> Value -> m ()
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
            [ Key
"tables"
                Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [ RawSQL () -> Text
unRawSQL RawSQL ()
tblName
                   | RawSQL ()
tblName <- [RawSQL ()]
tablesWithInvalidMigrationLists
                   ]
            ]
        [RawSQL ()] -> m ()
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [RawSQL ()]
tablesWithInvalidMigrationLists

    createDBSchema :: m ()
    createDBSchema :: m ()
createDBSchema = do
      Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Creating domains..."
      (Domain -> m ()) -> [Domain] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Domain -> m ()
forall (m :: * -> *). MonadDB m => Domain -> m ()
createDomain [Domain]
domains
      Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Creating enums..."
      (EnumType -> m ()) -> [EnumType] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (RawSQL () -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (RawSQL () -> m ()) -> (EnumType -> RawSQL ()) -> EnumType -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumType -> RawSQL ()
sqlCreateEnum) [EnumType]
enums
      -- Create all tables with no constraints first to allow cyclic references.
      Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Creating tables..."
      (Table -> m ()) -> [Table] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> Table -> m ()
forall (m :: * -> *). MonadDB m => Bool -> Table -> m ()
createTable Bool
False) [Table]
tables
      Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Creating table constraints..."
      (Table -> m ()) -> [Table] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Table -> m ()
forall (m :: * -> *). MonadDB m => Table -> m ()
createTableConstraints [Table]
tables
      Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Done."

    initializeDB :: m ()
    initializeDB :: m ()
initializeDB = do
      Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Running initial setup for tables..."
      [Table] -> (Table -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Table]
tables ((Table -> m ()) -> m ()) -> (Table -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Table
t -> case Table -> Maybe TableInitialSetup
tblInitialSetup Table
t of
        Maybe TableInitialSetup
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just TableInitialSetup
tis -> do
          Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Initializing" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Table -> Text
tblNameText Table
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"..."
          TableInitialSetup
-> forall (m :: * -> *). (MonadDB m, MonadThrow m) => m ()
initialSetup TableInitialSetup
tis
      Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Done."

    -- \| Input is a list of (table name, expected version, actual
    -- version) triples.
    validateMigrationsAgainstDB :: [(RawSQL (), Int32, Int32)] -> m ()
    validateMigrationsAgainstDB :: [(RawSQL (), Int32, Int32)] -> m ()
validateMigrationsAgainstDB [(RawSQL (), Int32, Int32)]
tablesWithVersions_ =
      [(RawSQL (), Int32, Int32)]
-> ((RawSQL (), Int32, Int32) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(RawSQL (), Int32, Int32)]
tablesWithVersions_ (((RawSQL (), Int32, Int32) -> m ()) -> m ())
-> ((RawSQL (), Int32, Int32) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(RawSQL ()
tableName, Int32
expectedVer, Int32
actualVer) ->
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int32
expectedVer Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int32
actualVer) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          case [ Migration m
m | m :: Migration m
m@Migration {Int32
RawSQL ()
MigrationAction m
mgrTableName :: forall (m :: * -> *). Migration m -> RawSQL ()
mgrFrom :: forall (m :: * -> *). Migration m -> Int32
mgrAction :: forall (m :: * -> *). Migration m -> MigrationAction m
mgrTableName :: RawSQL ()
mgrFrom :: Int32
mgrAction :: MigrationAction m
..} <- [Migration m]
migrations, RawSQL ()
mgrTableName RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
== RawSQL ()
tableName
               ] of
            [] ->
              String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
                String
"checkDBConsistency: no migrations found for table '"
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Text -> String
T.unpack (Text -> String) -> (RawSQL () -> Text) -> RawSQL () -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL (RawSQL () -> String) -> RawSQL () -> String
forall a b. (a -> b) -> a -> b
$ RawSQL ()
tableName)
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"', cannot migrate "
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int32 -> String
forall a. Show a => a -> String
show Int32
actualVer
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> "
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int32 -> String
forall a. Show a => a -> String
show Int32
expectedVer
            (Migration m
m : [Migration m]
_)
              | Migration m -> Int32
forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
m Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
> Int32
actualVer ->
                  String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
                    String
"checkDBConsistency: earliest migration for table '"
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Text -> String
T.unpack (Text -> String) -> (RawSQL () -> Text) -> RawSQL () -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL (RawSQL () -> String) -> RawSQL () -> String
forall a b. (a -> b) -> a -> b
$ RawSQL ()
tableName)
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is from version "
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int32 -> String
forall a. Show a => a -> String
show (Migration m -> Int32
forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
m)
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", cannot migrate "
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int32 -> String
forall a. Show a => a -> String
show Int32
actualVer
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> "
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int32 -> String
forall a. Show a => a -> String
show Int32
expectedVer
              | Bool
otherwise -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    validateDropTableMigrationsAgainstDB :: [(Text, Int32)] -> m ()
    validateDropTableMigrationsAgainstDB :: [(Text, Int32)] -> m ()
validateDropTableMigrationsAgainstDB [(Text, Int32)]
dbTablesWithVersions = do
      let dbTablesToDropWithVersions :: [(RawSQL (), Int32, Int32)]
dbTablesToDropWithVersions =
            [ (RawSQL ()
tblName, Migration m -> Int32
forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
mgr, Maybe Int32 -> Int32
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int32
mver)
            | Migration m
mgr <- [Migration m]
migrations
            , Migration m -> Bool
forall (m :: * -> *). Migration m -> Bool
isDropTableMigration Migration m
mgr
            , let tblName :: RawSQL ()
tblName = Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr
            , let mver :: Maybe Int32
mver = Text -> [(Text, Int32)] -> Maybe Int32
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (RawSQL () -> Text
unRawSQL RawSQL ()
tblName) [(Text, Int32)]
dbTablesWithVersions
            , Maybe Int32 -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int32
mver
            ]
      [(RawSQL (), Int32, Int32)]
-> ((RawSQL (), Int32, Int32) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(RawSQL (), Int32, Int32)]
dbTablesToDropWithVersions (((RawSQL (), Int32, Int32) -> m ()) -> m ())
-> ((RawSQL (), Int32, Int32) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(RawSQL ()
tblName, Int32
fromVer, Int32
ver) ->
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int32
fromVer Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int32
ver) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          -- In case when the table we're going to drop is an old
          -- version, check that there are migrations that bring it to
          -- a new one.
          [(RawSQL (), Int32, Int32)] -> m ()
validateMigrationsAgainstDB [(RawSQL ()
tblName, Int32
fromVer, Int32
ver)]

    findMigrationsToRun :: [(Text, Int32)] -> [Migration m]
    findMigrationsToRun :: [(Text, Int32)] -> [Migration m]
findMigrationsToRun [(Text, Int32)]
dbTablesWithVersions =
      let tableNamesToDrop :: [RawSQL ()]
tableNamesToDrop =
            [ Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr | Migration m
mgr <- [Migration m]
migrations, Migration m -> Bool
forall (m :: * -> *). Migration m -> Bool
isDropTableMigration Migration m
mgr
            ]
          droppedEventually :: Migration m -> Bool
          droppedEventually :: Migration m -> Bool
droppedEventually Migration m
mgr = Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr RawSQL () -> [RawSQL ()] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RawSQL ()]
tableNamesToDrop

          lookupVer :: Migration m -> Maybe Int32
          lookupVer :: Migration m -> Maybe Int32
lookupVer Migration m
mgr =
            Text -> [(Text, Int32)] -> Maybe Int32
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup
              (RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> RawSQL () -> Text
forall a b. (a -> b) -> a -> b
$ Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr)
              [(Text, Int32)]
dbTablesWithVersions

          tableDoesNotExist :: Migration m -> Bool
tableDoesNotExist = Maybe Int32 -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Int32 -> Bool)
-> (Migration m -> Maybe Int32) -> Migration m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Migration m -> Maybe Int32
lookupVer

          -- The idea here is that we find the first migration we need
          -- to run and then just run all migrations in order after
          -- that one.
          migrationsToRun' :: [Migration m]
migrationsToRun' =
            (Migration m -> Bool) -> [Migration m] -> [Migration m]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile
              ( \Migration m
mgr ->
                  case Migration m -> Maybe Int32
lookupVer Migration m
mgr of
                    -- Table doesn't exist in the DB. If it's a create
                    -- table migration and we're not going to drop the
                    -- table afterwards, this is our starting point.
                    Maybe Int32
Nothing ->
                      Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
                        (Migration m -> Int32
forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
mgr Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
0)
                          Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> (Migration m -> Bool) -> Migration m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Migration m -> Bool
droppedEventually (Migration m -> Bool) -> Migration m -> Bool
forall a b. (a -> b) -> a -> b
$ Migration m
mgr)
                    -- Table exists in the DB. Run only those migrations
                    -- that have mgrFrom >= table version in the DB.
                    Just Int32
ver -> Migration m -> Int32
forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
mgr Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
ver
              )
              [Migration m]
migrations

          -- Special case: also include migrations for tables that do
          -- not exist in the DB and ARE going to be dropped if they
          -- come as a consecutive list before the starting point that
          -- we've found.
          --
          -- Case in point: createTable t, doSomethingTo t,
          -- doSomethingTo t1, dropTable t. If our starting point is
          -- 'doSomethingTo t1', and that step depends on 't',
          -- 'doSomethingTo t1' will fail. So we include 'createTable
          -- t' and 'doSomethingTo t' as well.
          l :: Int
l = [Migration m] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Migration m]
migrationsToRun'
          initialMigrations :: [Migration m]
initialMigrations = Int -> [Migration m] -> [Migration m]
forall a. Int -> [a] -> [a]
drop Int
l ([Migration m] -> [Migration m]) -> [Migration m] -> [Migration m]
forall a b. (a -> b) -> a -> b
$ [Migration m] -> [Migration m]
forall a. [a] -> [a]
reverse [Migration m]
migrations
          additionalMigrations' :: [Migration m]
additionalMigrations' =
            (Migration m -> Bool) -> [Migration m] -> [Migration m]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile
              (\Migration m
mgr -> Migration m -> Bool
droppedEventually Migration m
mgr Bool -> Bool -> Bool
&& Migration m -> Bool
tableDoesNotExist Migration m
mgr)
              [Migration m]
initialMigrations
          -- Check that all extra migration chains we've chosen begin
          -- with 'createTable', otherwise skip adding them (to
          -- prevent raising an exception during the validation step).
          additionalMigrations :: [Migration m]
additionalMigrations =
            let ret :: [Migration m]
ret = [Migration m] -> [Migration m]
forall a. [a] -> [a]
reverse [Migration m]
additionalMigrations'
                grps :: [[Migration m]]
grps = (Migration m -> Migration m -> Bool)
-> [Migration m] -> [[Migration m]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
(==) (RawSQL () -> RawSQL () -> Bool)
-> (Migration m -> RawSQL ()) -> Migration m -> Migration m -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName) [Migration m]
ret
            in if ([Migration m] -> Bool) -> [[Migration m]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
(/=) Int32
0 (Int32 -> Bool)
-> ([Migration m] -> Int32) -> [Migration m] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Migration m -> Int32
forall (m :: * -> *). Migration m -> Int32
mgrFrom (Migration m -> Int32)
-> ([Migration m] -> Migration m) -> [Migration m] -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Migration m] -> Migration m
forall a. HasCallStack => [a] -> a
head) [[Migration m]]
grps
                then []
                else [Migration m]
ret
          -- Also there's no point in adding these extra migrations if
          -- we're not running any migrations to begin with.
          migrationsToRun :: [Migration m]
migrationsToRun =
            if Bool -> Bool
not (Bool -> Bool) -> ([Migration m] -> Bool) -> [Migration m] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Migration m] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Migration m] -> Bool) -> [Migration m] -> Bool
forall a b. (a -> b) -> a -> b
$ [Migration m]
migrationsToRun'
              then [Migration m]
additionalMigrations [Migration m] -> [Migration m] -> [Migration m]
forall a. [a] -> [a] -> [a]
++ [Migration m]
migrationsToRun'
              else []
      in [Migration m]
migrationsToRun

    runMigration :: Migration m -> m ()
    runMigration :: Migration m -> m ()
runMigration Migration {Int32
RawSQL ()
MigrationAction m
mgrTableName :: forall (m :: * -> *). Migration m -> RawSQL ()
mgrFrom :: forall (m :: * -> *). Migration m -> Int32
mgrAction :: forall (m :: * -> *). Migration m -> MigrationAction m
mgrTableName :: RawSQL ()
mgrFrom :: Int32
mgrAction :: MigrationAction m
..} = do
      case MigrationAction m
mgrAction of
        StandardMigration m ()
mgrDo -> do
          m ()
logMigration
          m ()
mgrDo
          m ()
updateTableVersion
        DropTableMigration DropTableMode
mgrDropTableMode -> do
          Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
arrListTable RawSQL ()
mgrTableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"drop table"
          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 () -> DropTableMode -> RawSQL ()
sqlDropTable
              RawSQL ()
mgrTableName
              DropTableMode
mgrDropTableMode
          SqlDelete -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (SqlDelete -> m ()) -> SqlDelete -> m ()
forall a b. (a -> b) -> a -> b
$ SQL -> State SqlDelete () -> SqlDelete
sqlDelete SQL
"table_versions" (State SqlDelete () -> SqlDelete)
-> State SqlDelete () -> SqlDelete
forall a b. (a -> b) -> a -> b
$ do
            SQL -> String -> State SqlDelete ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"name" (Text -> String
T.unpack (Text -> String) -> (RawSQL () -> Text) -> RawSQL () -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL (RawSQL () -> String) -> RawSQL () -> String
forall a b. (a -> b) -> a -> b
$ RawSQL ()
mgrTableName)
        CreateIndexConcurrentlyMigration RawSQL ()
tname TableIndex
idx -> do
          m ()
logMigration
          -- We're in auto transaction mode (as ensured at the beginning of
          -- 'checkDBConsistency'), so we need to issue explicit SQL commit,
          -- because using 'commit' function automatically starts another
          -- transaction. We don't want that as concurrent creation of index
          -- won't run inside a transaction.
          m () -> m () -> m () -> m ()
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ (SQL -> m ()
forall (m :: * -> *). (HasCallStack, MonadDB m) => SQL -> m ()
runSQL_ SQL
"COMMIT") (SQL -> m ()
forall (m :: * -> *). (HasCallStack, MonadDB m) => SQL -> m ()
runSQL_ SQL
"BEGIN") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            -- If migration was run before but creation of an index failed, index
            -- will be left in the database in an inactive state, so when we
            -- rerun, we need to remove it first (see
            -- https://www.postgresql.org/docs/9.6/sql-createindex.html for more
            -- information).
            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 ()
"DROP INDEX CONCURRENTLY IF EXISTS" RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> TableIndex -> RawSQL ()
indexName RawSQL ()
tname TableIndex
idx
            RawSQL () -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (RawSQL () -> TableIndex -> RawSQL ()
sqlCreateIndexConcurrently RawSQL ()
tname TableIndex
idx)
          m ()
updateTableVersion
        DropIndexConcurrentlyMigration RawSQL ()
tname TableIndex
idx -> do
          m ()
logMigration
          -- We're in auto transaction mode (as ensured at the beginning of
          -- 'checkDBConsistency'), so we need to issue explicit SQL commit,
          -- because using 'commit' function automatically starts another
          -- transaction. We don't want that as concurrent dropping of index
          -- won't run inside a transaction.
          m () -> m () -> m () -> m ()
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ (SQL -> m ()
forall (m :: * -> *). (HasCallStack, MonadDB m) => SQL -> m ()
runSQL_ SQL
"COMMIT") (SQL -> m ()
forall (m :: * -> *). (HasCallStack, MonadDB m) => SQL -> m ()
runSQL_ SQL
"BEGIN") (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 () -> TableIndex -> RawSQL ()
sqlDropIndexConcurrently RawSQL ()
tname TableIndex
idx)
          m ()
updateTableVersion
        ModifyColumnMigration RawSQL ()
tableName SQL
cursorSql [t] -> m ()
updateSql Int
batchSize -> do
          m ()
logMigration
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
batchSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1000) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            String -> m ()
forall a. HasCallStack => String -> a
error String
"Batch size cannot be less than 1000"
          CursorName SQL
-> Scroll -> Hold -> SQL -> (Cursor SQL -> m ()) -> m ()
forall (m :: * -> *) r.
(MonadDB m, MonadMask m) =>
CursorName SQL
-> Scroll -> Hold -> SQL -> (Cursor SQL -> m r) -> m r
withCursorSQL CursorName SQL
"migration_cursor" Scroll
NoScroll Hold
Hold SQL
cursorSql ((Cursor SQL -> m ()) -> m ()) -> (Cursor SQL -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Cursor SQL
cursor -> do
            -- Vacuum should be done approximately once every 5% of the table
            -- has been updated, or every 1000 rows as a minimum.
            --
            -- In PostgreSQL, when a record is updated, a new version of this
            -- record is created. The old one is destroyed by the "vacuum"
            -- command when no transaction needs it anymore. So there's an
            -- autovacuum daemon whose purpose is to do this cleanup, and that
            -- is sufficient most of the time. We assume that it's tuned to try
            -- to keep the "bloat" (dead records) at around 10% of the table
            -- size in the environment, and it's also tuned to not saturate the
            -- server with IO operations while doing the vacuum - vacuuming is
            -- IO intensive as there are a lot of reads and rewrites, which
            -- makes it slow and costly. So, autovacuum wouldn't be able to keep
            -- up with the aggressive batch update. Therefore we need to run
            -- vacuum ourselves, to keep things in check. The 5% limit is
            -- arbitrary, but a reasonable ballpark estimate: it more or less
            -- makes sure we keep dead records in the 10% envelope and the table
            -- doesn't grow too much during the operation.
            Int
vacuumThreshold <- Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1000 (Int -> Int) -> (Int32 -> Int) -> Int32 -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> (Int32 -> Int32) -> Int32 -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int32 -> Int32 -> Int32
forall a. Integral a => a -> a -> a
`div` Int32
20) (Int32 -> Int) -> m Int32 -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawSQL () -> m Int32
MonadDB m => RawSQL () -> m Int32
getRowEstimate RawSQL ()
tableName
            let cursorLoop :: Int -> m ()
cursorLoop Int
processed = do
                  Cursor SQL -> CursorDirection -> m ()
forall sql (m :: * -> *).
(IsSQL sql, IsString sql, Monoid sql, MonadDB m) =>
Cursor sql -> CursorDirection -> m ()
cursorFetch_ Cursor SQL
cursor (Int -> CursorDirection
CD_Forward Int
batchSize)
                  [t]
primaryKeys <- (t -> t) -> m [t]
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany t -> t
forall a. a -> a
id
                  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([t] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [t]
primaryKeys) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                    [t] -> m ()
updateSql [t]
primaryKeys
                    if Int
processed Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
batchSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
vacuumThreshold
                      then do
                        m () -> m () -> m () -> m ()
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_
                          (SQL -> m ()
forall (m :: * -> *). (HasCallStack, MonadDB m) => SQL -> m ()
runSQL_ SQL
"COMMIT")
                          (SQL -> m ()
forall (m :: * -> *). (HasCallStack, MonadDB m) => SQL -> m ()
runSQL_ SQL
"BEGIN")
                          (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 ()
"VACUUM" RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
tableName)
                        Int -> m ()
cursorLoop Int
0
                      else do
                        m ()
forall (m :: * -> *). (HasCallStack, MonadDB m) => m ()
commit
                        Int -> m ()
cursorLoop (Int
processed Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
batchSize)
            Int -> m ()
cursorLoop Int
0
          m ()
updateTableVersion
      where
        logMigration :: m ()
logMigration = do
          Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
            RawSQL () -> Text
arrListTable RawSQL ()
mgrTableName
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int32 -> Text
forall a. TextShow a => a -> Text
showt Int32
mgrFrom
              Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"->"
              Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Int32 -> Text
forall a. TextShow a => a -> Text
showt (Int32 -> Int32
forall a. Enum a => a -> a
succ Int32
mgrFrom)

        updateTableVersion :: m ()
updateTableVersion = do
          SqlUpdate -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (SqlUpdate -> m ()) -> SqlUpdate -> m ()
forall a b. (a -> b) -> a -> b
$ SQL -> State SqlUpdate () -> SqlUpdate
sqlUpdate SQL
"table_versions" (State SqlUpdate () -> SqlUpdate)
-> State SqlUpdate () -> SqlUpdate
forall a b. (a -> b) -> a -> b
$ do
            SQL -> Int32 -> State SqlUpdate ()
forall v (m :: * -> *) a.
(MonadState v m, SqlSet v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlSet SQL
"version" (Int32 -> Int32
forall a. Enum a => a -> a
succ Int32
mgrFrom)
            SQL -> String -> State SqlUpdate ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"name" (Text -> String
T.unpack (Text -> String) -> (RawSQL () -> Text) -> RawSQL () -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL (RawSQL () -> String) -> RawSQL () -> String
forall a b. (a -> b) -> a -> b
$ RawSQL ()
mgrTableName)

        -- Get the estimated number of rows of the given table. It might not
        -- work properly if the table is present in multiple database schemas.
        -- See https://wiki.postgresql.org/wiki/Count_estimate.
        getRowEstimate :: MonadDB m => RawSQL () -> m Int32
        getRowEstimate :: MonadDB m => RawSQL () -> m Int32
getRowEstimate RawSQL ()
tableName = do
          SqlSelect -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (SqlSelect -> m ())
-> (State SqlSelect () -> SqlSelect) -> State SqlSelect () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_class" (State SqlSelect () -> m ()) -> State SqlSelect () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"reltuples::integer"
            SQL -> Text -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"relname" (Text -> State SqlSelect ()) -> Text -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
unRawSQL RawSQL ()
tableName
          (Identity Int32 -> Int32) -> m Int32
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m t
fetchOne Identity Int32 -> Int32
forall a. Identity a -> a
runIdentity

    runMigrations :: [(Text, Int32)] -> m ()
    runMigrations :: [(Text, Int32)] -> m ()
runMigrations [(Text, Int32)]
dbTablesWithVersions = do
      let migrationsToRun :: [Migration m]
migrationsToRun = [(Text, Int32)] -> [Migration m]
findMigrationsToRun [(Text, Int32)]
dbTablesWithVersions
      [Migration m] -> [(Text, Int32)] -> m ()
validateMigrationsToRun [Migration m]
migrationsToRun [(Text, Int32)]
dbTablesWithVersions
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Migration m] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Migration m]
migrationsToRun) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Running migrations..."
        [Migration m] -> (Migration m -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Migration m]
migrationsToRun ((Migration m -> m ()) -> m ()) -> (Migration m -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Migration m
mgr -> (m () -> m ()) -> m ()
forall a. (a -> a) -> a
fix ((m () -> m ()) -> m ()) -> (m () -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \m ()
loop -> do
          let restartMigration :: String -> m ()
restartMigration String
query = do
                Text -> Value -> m ()
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention Text
"Failed to acquire a lock" (Value -> m ()) -> Value -> m ()
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Key
"query" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
query]
                Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Restarting the migration shortly..."
                IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
1000000
                m ()
loop
          (DBException -> Maybe String) -> (String -> m ()) -> m () -> m ()
forall (m :: * -> *) e b a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
handleJust DBException -> Maybe String
lockNotAvailable String -> m ()
restartMigration (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            Maybe Int -> (Int -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ExtrasOptions -> Maybe Int
eoLockTimeoutMs ExtrasOptions
options) ((Int -> m ()) -> m ()) -> (Int -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Int
lockTimeout -> do
              SQL -> m ()
forall (m :: * -> *). (HasCallStack, MonadDB m) => SQL -> m ()
runSQL_ (SQL -> m ()) -> SQL -> m ()
forall a b. (a -> b) -> a -> b
$ SQL
"SET LOCAL lock_timeout TO" SQL -> SQL -> SQL
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Int -> SQL
intToSQL Int
lockTimeout
            Migration m -> m ()
runMigration Migration m
mgr m () -> m () -> m ()
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
`onException` m ()
forall (m :: * -> *). (HasCallStack, MonadDB m) => m ()
rollback
            Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Committing migration changes..."
            m ()
forall (m :: * -> *). (HasCallStack, MonadDB m) => m ()
commit
        Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Running migrations... done."
      where
        intToSQL :: Int -> SQL
        intToSQL :: Int -> SQL
intToSQL = String -> SQL
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL (String -> SQL) -> (Int -> String) -> Int -> SQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show

        lockNotAvailable :: DBException -> Maybe String
        lockNotAvailable :: DBException -> Maybe String
lockNotAvailable DBException {e
sql
CallStack
BackendPid
dbeQueryContext :: sql
dbeBackendPid :: BackendPid
dbeError :: e
dbeCallStack :: CallStack
dbeQueryContext :: ()
dbeBackendPid :: DBException -> BackendPid
dbeError :: ()
dbeCallStack :: DBException -> CallStack
..}
          | Just DetailedQueryError {String
Maybe Int
Maybe String
ErrorCode
qeSeverity :: String
qeErrorCode :: ErrorCode
qeMessagePrimary :: String
qeMessageDetail :: Maybe String
qeMessageHint :: Maybe String
qeStatementPosition :: Maybe Int
qeInternalPosition :: Maybe Int
qeInternalQuery :: Maybe String
qeContext :: Maybe String
qeSourceFile :: Maybe String
qeSourceLine :: Maybe Int
qeSourceFunction :: Maybe String
qeSeverity :: DetailedQueryError -> String
qeErrorCode :: DetailedQueryError -> ErrorCode
qeMessagePrimary :: DetailedQueryError -> String
qeMessageDetail :: DetailedQueryError -> Maybe String
qeMessageHint :: DetailedQueryError -> Maybe String
qeStatementPosition :: DetailedQueryError -> Maybe Int
qeInternalPosition :: DetailedQueryError -> Maybe Int
qeInternalQuery :: DetailedQueryError -> Maybe String
qeContext :: DetailedQueryError -> Maybe String
qeSourceFile :: DetailedQueryError -> Maybe String
qeSourceLine :: DetailedQueryError -> Maybe Int
qeSourceFunction :: DetailedQueryError -> Maybe String
..} <- e -> Maybe DetailedQueryError
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
dbeError
          , ErrorCode
qeErrorCode ErrorCode -> ErrorCode -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorCode
LockNotAvailable =
              String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ sql -> String
forall a. Show a => a -> String
show sql
dbeQueryContext
          | Bool
otherwise = Maybe String
forall a. Maybe a
Nothing

    validateMigrationsToRun :: [Migration m] -> [(Text, Int32)] -> m ()
    validateMigrationsToRun :: [Migration m] -> [(Text, Int32)] -> m ()
validateMigrationsToRun [Migration m]
migrationsToRun [(Text, Int32)]
dbTablesWithVersions = do
      let migrationsToRunGrouped :: [[Migration m]]
          migrationsToRunGrouped :: [[Migration m]]
migrationsToRunGrouped =
            (Migration m -> Migration m -> Bool)
-> [Migration m] -> [[Migration m]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
(==) (RawSQL () -> RawSQL () -> Bool)
-> (Migration m -> RawSQL ()) -> Migration m -> Migration m -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName)
              ([Migration m] -> [[Migration m]])
-> ([Migration m] -> [Migration m])
-> [Migration m]
-> [[Migration m]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Migration m -> RawSQL ()) -> [Migration m] -> [Migration m]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName
              ([Migration m] -> [[Migration m]])
-> [Migration m] -> [[Migration m]]
forall a b. (a -> b) -> a -> b
$ [Migration m]
migrationsToRun -- NB: stable sort
          loc_common :: String
loc_common =
            String
"Database.PostgreSQL.PQTypes.Checks."
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"checkDBConsistency.validateMigrationsToRun"

          lookupDBTableVer :: [Migration m] -> Maybe Int32
          lookupDBTableVer :: [Migration m] -> Maybe Int32
lookupDBTableVer [Migration m]
mgrGroup =
            Text -> [(Text, Int32)] -> Maybe Int32
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup
              ( RawSQL () -> Text
unRawSQL (RawSQL () -> Text)
-> ([Migration m] -> RawSQL ()) -> [Migration m] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName (Migration m -> RawSQL ())
-> ([Migration m] -> Migration m) -> [Migration m] -> RawSQL ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Migration m] -> Migration m
forall a. String -> [a] -> a
headExc String
head_err ([Migration m] -> Text) -> [Migration m] -> Text
forall a b. (a -> b) -> a -> b
$
                  [Migration m]
mgrGroup
              )
              [(Text, Int32)]
dbTablesWithVersions
            where
              head_err :: String
head_err = String
loc_common String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".lookupDBTableVer: broken invariant"

          groupsWithWrongDBTableVersions :: [([Migration m], Int32)]
          groupsWithWrongDBTableVersions :: [([Migration m], Int32)]
groupsWithWrongDBTableVersions =
            [ ([Migration m]
mgrGroup, Int32
dbTableVer)
            | [Migration m]
mgrGroup <- [[Migration m]]
migrationsToRunGrouped
            , let dbTableVer :: Int32
dbTableVer = Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 (Maybe Int32 -> Int32) -> Maybe Int32 -> Int32
forall a b. (a -> b) -> a -> b
$ [Migration m] -> Maybe Int32
lookupDBTableVer [Migration m]
mgrGroup
            , Int32
dbTableVer Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
/= (Migration m -> Int32
forall (m :: * -> *). Migration m -> Int32
mgrFrom (Migration m -> Int32)
-> ([Migration m] -> Migration m) -> [Migration m] -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Migration m] -> Migration m
forall a. String -> [a] -> a
headExc String
head_err ([Migration m] -> Int32) -> [Migration m] -> Int32
forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrGroup)
            ]
            where
              head_err :: String
head_err =
                String
loc_common
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".groupsWithWrongDBTableVersions: broken invariant"

          mgrGroupsNotInDB :: [[Migration m]]
          mgrGroupsNotInDB :: [[Migration m]]
mgrGroupsNotInDB =
            [ [Migration m]
mgrGroup
            | [Migration m]
mgrGroup <- [[Migration m]]
migrationsToRunGrouped
            , Maybe Int32 -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Int32 -> Bool) -> Maybe Int32 -> Bool
forall a b. (a -> b) -> a -> b
$ [Migration m] -> Maybe Int32
lookupDBTableVer [Migration m]
mgrGroup
            ]

          groupsStartingWithDropTable :: [[Migration m]]
          groupsStartingWithDropTable :: [[Migration m]]
groupsStartingWithDropTable =
            [ [Migration m]
mgrGroup
            | [Migration m]
mgrGroup <- [[Migration m]]
mgrGroupsNotInDB
            , Migration m -> Bool
forall (m :: * -> *). Migration m -> Bool
isDropTableMigration (Migration m -> Bool)
-> ([Migration m] -> Migration m) -> [Migration m] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Migration m] -> Migration m
forall a. String -> [a] -> a
headExc String
head_err ([Migration m] -> Bool) -> [Migration m] -> Bool
forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrGroup
            ]
            where
              head_err :: String
head_err =
                String
loc_common
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".groupsStartingWithDropTable: broken invariant"

          groupsNotStartingWithCreateTable :: [[Migration m]]
          groupsNotStartingWithCreateTable :: [[Migration m]]
groupsNotStartingWithCreateTable =
            [ [Migration m]
mgrGroup
            | [Migration m]
mgrGroup <- [[Migration m]]
mgrGroupsNotInDB
            , Migration m -> Int32
forall (m :: * -> *). Migration m -> Int32
mgrFrom (String -> [Migration m] -> Migration m
forall a. String -> [a] -> a
headExc String
head_err [Migration m]
mgrGroup) Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int32
0
            ]
            where
              head_err :: String
head_err =
                String
loc_common
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".groupsNotStartingWithCreateTable: broken invariant"

          tblNames :: [[Migration m]] -> [RawSQL ()]
          tblNames :: [[Migration m]] -> [RawSQL ()]
tblNames [[Migration m]]
grps =
            [Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName (Migration m -> RawSQL ())
-> ([Migration m] -> Migration m) -> [Migration m] -> RawSQL ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Migration m] -> Migration m
forall a. String -> [a] -> a
headExc String
head_err ([Migration m] -> RawSQL ()) -> [Migration m] -> RawSQL ()
forall a b. (a -> b) -> a -> b
$ [Migration m]
grp | [Migration m]
grp <- [[Migration m]]
grps]
            where
              head_err :: String
head_err = String
loc_common String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".tblNames: broken invariant"

      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([([Migration m], Int32)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Migration m], Int32)]
groupsWithWrongDBTableVersions) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        let tnms :: [RawSQL ()]
tnms = [[Migration m]] -> [RawSQL ()]
tblNames ([[Migration m]] -> [RawSQL ()])
-> ([([Migration m], Int32)] -> [[Migration m]])
-> [([Migration m], Int32)]
-> [RawSQL ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Migration m], Int32) -> [Migration m])
-> [([Migration m], Int32)] -> [[Migration m]]
forall a b. (a -> b) -> [a] -> [b]
map ([Migration m], Int32) -> [Migration m]
forall a b. (a, b) -> a
fst ([([Migration m], Int32)] -> [RawSQL ()])
-> [([Migration m], Int32)] -> [RawSQL ()]
forall a b. (a -> b) -> a -> b
$ [([Migration m], Int32)]
groupsWithWrongDBTableVersions
        Text -> Value -> m ()
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention
          ( Text
"There are migration chains selected for execution "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"that expect a different starting table version number "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"from the one in the database. "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"This likely means that the order of migrations is wrong."
          )
          (Value -> m ()) -> Value -> m ()
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Key
"tables" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (RawSQL () -> Text) -> [RawSQL ()] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map RawSQL () -> Text
unRawSQL [RawSQL ()]
tnms]
        [RawSQL ()] -> m ()
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [RawSQL ()]
tnms

      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Migration m]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Migration m]]
groupsStartingWithDropTable) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        let tnms :: [RawSQL ()]
tnms = [[Migration m]] -> [RawSQL ()]
tblNames [[Migration m]]
groupsStartingWithDropTable
        Text -> Value -> m ()
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention Text
"There are drop table migrations for non-existing tables." (Value -> m ()) -> Value -> m ()
forall a b. (a -> b) -> a -> b
$
          [Pair] -> Value
object [Key
"tables" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (RawSQL () -> Text) -> [RawSQL ()] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map RawSQL () -> Text
unRawSQL [RawSQL ()]
tnms]
        [RawSQL ()] -> m ()
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [RawSQL ()]
tnms

      -- NB: the following check can break if we allow renaming tables.
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Migration m]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Migration m]]
groupsNotStartingWithCreateTable) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        let tnms :: [RawSQL ()]
tnms = [[Migration m]] -> [RawSQL ()]
tblNames [[Migration m]]
groupsNotStartingWithCreateTable
        Text -> Value -> m ()
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention
          ( Text
"Some tables haven't been created yet, but"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"their migration lists don't start with a create table migration."
          )
          (Value -> m ()) -> Value -> m ()
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Key
"tables" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (RawSQL () -> Text) -> [RawSQL ()] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map RawSQL () -> Text
unRawSQL [RawSQL ()]
tnms]
        [RawSQL ()] -> m ()
forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [RawSQL ()]
tnms

-- | Type synonym for a list of tables along with their database versions.
type TablesWithVersions = [(Table, Int32)]

-- The server_version_num has been there since 8.2
checkVersionIsAtLeast15 :: (MonadDB m, MonadThrow m) => m Bool
checkVersionIsAtLeast15 :: forall (m :: * -> *). (MonadDB m, MonadThrow m) => m Bool
checkVersionIsAtLeast15 = do
  SQL -> m ()
forall (m :: * -> *).
(HasCallStack, MonadDB m, MonadThrow m) =>
SQL -> m ()
runSQL01_ SQL
"select current_setting('server_version_num',true)::int >= 150000;"
  (Identity Bool -> Bool) -> m Bool
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m t
fetchOne Identity Bool -> Bool
forall a. Identity a -> a
runIdentity

-- | Associate each table in the list with its version as it exists in
-- the DB, or 0 if it's missing from the DB.
getTableVersions :: (MonadDB m, MonadThrow m) => [Table] -> m TablesWithVersions
getTableVersions :: forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Table] -> m TablesWithVersions
getTableVersions [Table]
tbls =
  [m (Table, Int32)] -> m TablesWithVersions
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
    [ (\Maybe Int32
mver -> (Table
tbl, Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 Maybe Int32
mver)) (Maybe Int32 -> (Table, Int32))
-> m (Maybe Int32) -> m (Table, Int32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m (Maybe Int32)
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
String -> m (Maybe Int32)
checkTableVersion (Table -> String
tblNameString Table
tbl)
    | Table
tbl <- [Table]
tbls
    ]

-- | Given a result of 'getTableVersions' check if no tables are present in the
-- database.
noTablesPresent :: TablesWithVersions -> Bool
noTablesPresent :: TablesWithVersions -> Bool
noTablesPresent = ((Table, Int32) -> Bool) -> TablesWithVersions -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
(==) Int32
0 (Int32 -> Bool)
-> ((Table, Int32) -> Int32) -> (Table, Int32) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Table, Int32) -> Int32
forall a b. (a, b) -> b
snd)

-- | Like 'getTableVersions', but for all user-defined tables that
-- actually exist in the DB.
getDBTableVersions :: (MonadDB m, MonadThrow m) => m [(Text, Int32)]
getDBTableVersions :: forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
m [(Text, Int32)]
getDBTableVersions = do
  [Text]
dbTableNames <- m [Text]
forall (m :: * -> *). MonadDB m => m [Text]
getDBTableNames
  [m (Text, Int32)] -> m [(Text, Int32)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
    [ (\Maybe Int32
mver -> (Text
name, Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 Maybe Int32
mver)) (Maybe Int32 -> (Text, Int32))
-> m (Maybe Int32) -> m (Text, Int32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m (Maybe Int32)
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
String -> m (Maybe Int32)
checkTableVersion (Text -> String
T.unpack Text
name)
    | Text
name <- [Text]
dbTableNames
    ]

-- | Check whether the table exists in the DB, and return 'Just' its
-- version if it does, or 'Nothing' if it doesn't.
checkTableVersion :: (MonadDB m, MonadThrow m) => String -> m (Maybe Int32)
checkTableVersion :: forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
String -> m (Maybe Int32)
checkTableVersion String
tblName = do
  Bool
doesExist <- SqlSelect -> m Bool
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m, MonadThrow m) =>
sql -> m Bool
runQuery01 (SqlSelect -> m Bool)
-> (State SqlSelect () -> SqlSelect)
-> State SqlSelect ()
-> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_class c" (State SqlSelect () -> m Bool) -> State SqlSelect () -> m Bool
forall a b. (a -> b) -> a -> b
$ do
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"TRUE"
    SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlLeftJoinOn SQL
"pg_catalog.pg_namespace n" SQL
"n.oid = c.relnamespace"
    SQL -> String -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c.relname" String
tblName
    SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"pg_catalog.pg_table_is_visible(c.oid)"
  if Bool
doesExist
    then do
      SQL -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (SQL -> m ()) -> SQL -> m ()
forall a b. (a -> b) -> a -> b
$
        SQL
"SELECT version FROM table_versions WHERE name ="
          SQL -> String -> SQL
forall t. (Show t, ToSQL t) => SQL -> t -> SQL
<?> String
tblName
      Maybe Int32
mver <- (Identity Int32 -> Int32) -> m (Maybe Int32)
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m (Maybe t)
fetchMaybe Identity Int32 -> Int32
forall a. Identity a -> a
runIdentity
      case Maybe Int32
mver of
        Just Int32
ver -> Maybe Int32 -> m (Maybe Int32)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int32 -> m (Maybe Int32)) -> Maybe Int32 -> m (Maybe Int32)
forall a b. (a -> b) -> a -> b
$ Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
ver
        Maybe Int32
Nothing ->
          String -> m (Maybe Int32)
forall a. HasCallStack => String -> a
error (String -> m (Maybe Int32)) -> String -> m (Maybe Int32)
forall a b. (a -> b) -> a -> b
$
            String
"checkTableVersion: table '"
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tblName
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is present in the database, "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"but there is no corresponding version info in 'table_versions'."
    else do
      Maybe Int32 -> m (Maybe Int32)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int32
forall a. Maybe a
Nothing

-- *** TABLE STRUCTURE ***

sqlGetTableID :: Table -> SQL
sqlGetTableID :: Table -> SQL
sqlGetTableID Table
table = SQL -> SQL
parenthesize (SQL -> SQL) -> (SqlSelect -> SQL) -> SqlSelect -> SQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlSelect -> SQL
forall a. Sqlable a => a -> SQL
toSQLCommand (SqlSelect -> SQL) -> SqlSelect -> SQL
forall a b. (a -> b) -> a -> b
$
  SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_class c" (State SqlSelect () -> SqlSelect)
-> State SqlSelect () -> SqlSelect
forall a b. (a -> b) -> a -> b
$ do
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.oid"
    SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlLeftJoinOn SQL
"pg_catalog.pg_namespace n" SQL
"n.oid = c.relnamespace"
    SQL -> String -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c.relname" (String -> State SqlSelect ()) -> String -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ Table -> String
tblNameString Table
table
    SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"pg_catalog.pg_table_is_visible(c.oid)"

-- *** PRIMARY KEY ***

sqlGetPrimaryKey
  :: (MonadDB m, MonadThrow m)
  => Table
  -> m (Maybe (PrimaryKey, RawSQL ()))
sqlGetPrimaryKey :: forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
Table -> m (Maybe (PrimaryKey, RawSQL ()))
sqlGetPrimaryKey Table
table = do
  (Maybe [Int16]
mColumnNumbers :: Maybe [Int16]) <- do
    SqlSelect -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (SqlSelect -> m ())
-> (State SqlSelect () -> SqlSelect) -> State SqlSelect () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_constraint" (State SqlSelect () -> m ()) -> State SqlSelect () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"conkey"
      SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"conrelid" (Table -> SQL
sqlGetTableID Table
table)
      SQL -> Char -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"contype" Char
'p'
    (Identity (Array1 Int16) -> [Int16]) -> m (Maybe [Int16])
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m (Maybe t)
fetchMaybe ((Identity (Array1 Int16) -> [Int16]) -> m (Maybe [Int16]))
-> (Identity (Array1 Int16) -> [Int16]) -> m (Maybe [Int16])
forall a b. (a -> b) -> a -> b
$ Array1 Int16 -> [Int16]
forall a. Array1 a -> [a]
unArray1 (Array1 Int16 -> [Int16])
-> (Identity (Array1 Int16) -> Array1 Int16)
-> Identity (Array1 Int16)
-> [Int16]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (Array1 Int16) -> Array1 Int16
forall a. Identity a -> a
runIdentity

  case Maybe [Int16]
mColumnNumbers of
    Maybe [Int16]
Nothing -> do Maybe (PrimaryKey, RawSQL ()) -> m (Maybe (PrimaryKey, RawSQL ()))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (PrimaryKey, RawSQL ())
forall a. Maybe a
Nothing
    Just [Int16]
columnNumbers -> do
      [String]
columnNames <- do
        [Int16] -> (Int16 -> m String) -> m [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int16]
columnNumbers ((Int16 -> m String) -> m [String])
-> (Int16 -> m String) -> m [String]
forall a b. (a -> b) -> a -> b
$ \Int16
k -> do
          SqlSelect -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (SqlSelect -> m ())
-> (State SqlSelect () -> SqlSelect) -> State SqlSelect () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pk_columns" (State SqlSelect () -> m ()) -> State SqlSelect () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            SQL -> SqlSelect -> State SqlSelect ()
forall v (m :: * -> *) s.
(MonadState v m, SqlWith v, Sqlable s) =>
SQL -> s -> m ()
sqlWith SQL
"key_series" (SqlSelect -> State SqlSelect ())
-> (State SqlSelect () -> SqlSelect)
-> State SqlSelect ()
-> State SqlSelect ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_constraint as c2" (State SqlSelect () -> State SqlSelect ())
-> State SqlSelect () -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ do
              SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"unnest(c2.conkey) as k"
              SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"c2.conrelid" (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
              SQL -> Char -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c2.contype" Char
'p'

            SQL -> SqlSelect -> State SqlSelect ()
forall v (m :: * -> *) s.
(MonadState v m, SqlWith v, Sqlable s) =>
SQL -> s -> m ()
sqlWith SQL
"pk_columns" (SqlSelect -> State SqlSelect ())
-> (State SqlSelect () -> SqlSelect)
-> State SqlSelect ()
-> State SqlSelect ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"key_series" (State SqlSelect () -> State SqlSelect ())
-> State SqlSelect () -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ do
              SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlJoinOn SQL
"pg_catalog.pg_attribute as a" SQL
"a.attnum = key_series.k"
              SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"a.attname::text as column_name"
              SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"key_series.k as column_order"
              SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"a.attrelid" (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table

            SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pk_columns.column_name"
            SQL -> Int16 -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"pk_columns.column_order" Int16
k

          (Identity String -> String) -> m String
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m t
fetchOne (\(Identity String
t) -> String
t :: String)

      SqlSelect -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (SqlSelect -> m ())
-> (State SqlSelect () -> SqlSelect) -> State SqlSelect () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_constraint as c" (State SqlSelect () -> m ()) -> State SqlSelect () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        SQL -> Char -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c.contype" Char
'p'
        SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"c.conrelid" (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
        SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.conname::text"
        SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$
          String -> SQL
forall a. IsString a => String -> a
Data.String.fromString
            (String
"array['" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall m. Monoid m => m -> [m] -> m
mintercalate String
"', '" [String]
columnNames String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"']::text[]")

      Maybe (Maybe (PrimaryKey, RawSQL ()))
-> Maybe (PrimaryKey, RawSQL ())
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (PrimaryKey, RawSQL ()))
 -> Maybe (PrimaryKey, RawSQL ()))
-> m (Maybe (Maybe (PrimaryKey, RawSQL ())))
-> m (Maybe (PrimaryKey, RawSQL ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String, Array1 String) -> Maybe (PrimaryKey, RawSQL ()))
-> m (Maybe (Maybe (PrimaryKey, RawSQL ())))
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m (Maybe t)
fetchMaybe (String, Array1 String) -> Maybe (PrimaryKey, RawSQL ())
fetchPrimaryKey

fetchPrimaryKey :: (String, Array1 String) -> Maybe (PrimaryKey, RawSQL ())
fetchPrimaryKey :: (String, Array1 String) -> Maybe (PrimaryKey, RawSQL ())
fetchPrimaryKey (String
name, Array1 [String]
columns) =
  (,String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name)
    (PrimaryKey -> (PrimaryKey, RawSQL ()))
-> Maybe PrimaryKey -> Maybe (PrimaryKey, RawSQL ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RawSQL ()] -> Maybe PrimaryKey
pkOnColumns ((String -> RawSQL ()) -> [String] -> [RawSQL ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL [String]
columns)

-- *** CHECKS ***

sqlGetChecks :: Table -> SQL
sqlGetChecks :: Table -> SQL
sqlGetChecks Table
table = SqlSelect -> SQL
forall a. Sqlable a => a -> SQL
toSQLCommand (SqlSelect -> SQL)
-> (State SqlSelect () -> SqlSelect) -> State SqlSelect () -> SQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_constraint c" (State SqlSelect () -> SQL) -> State SqlSelect () -> SQL
forall a b. (a -> b) -> a -> b
$ do
  SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.conname::text"
  SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult
    SQL
"regexp_replace(pg_get_constraintdef(c.oid, true), \
    \'CHECK \\((.*)\\)', '\\1') AS body" -- check body
  SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.convalidated" -- validated?
  SQL -> Char -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c.contype" Char
'c'
  SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"c.conrelid" (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table

fetchTableCheck :: (String, String, Bool) -> Check
fetchTableCheck :: (String, String, Bool) -> Check
fetchTableCheck (String
name, String
condition, Bool
validated) =
  Check
    { chkName :: RawSQL ()
chkName = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name
    , chkCondition :: RawSQL ()
chkCondition = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
condition
    , chkValidated :: Bool
chkValidated = Bool
validated
    }

-- *** INDEXES ***
sqlGetIndexes :: Bool -> Table -> SQL
sqlGetIndexes :: Bool -> Table -> SQL
sqlGetIndexes Bool
nullsNotDistinctSupported Table
table = SqlSelect -> SQL
forall a. Sqlable a => a -> SQL
toSQLCommand (SqlSelect -> SQL)
-> (State SqlSelect () -> SqlSelect) -> State SqlSelect () -> SQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_class c" (State SqlSelect () -> SQL) -> State SqlSelect () -> SQL
forall a b. (a -> b) -> a -> b
$ do
  SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.relname::text" -- index name
  SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ SQL
"ARRAY(" SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> SQL -> SQL -> SQL
forall m. (IsString m, Monoid m) => m -> m -> m
selectCoordinates SQL
"0" SQL
"i.indnkeyatts" SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> SQL
")" -- array of key columns in the index
  SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ SQL
"ARRAY(" SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> SQL -> SQL -> SQL
forall m. (IsString m, Monoid m) => m -> m -> m
selectCoordinates SQL
"i.indnkeyatts" SQL
"i.indnatts" SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> SQL
")" -- array of included columns in the index
  SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"am.amname::text" -- the method used (btree, gin etc)
  SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"i.indisunique" -- is it unique?
  SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"i.indisvalid" -- is it valid?
  -- does it have NULLS NOT DISTINCT ?
  if Bool
nullsNotDistinctSupported
    then SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"i.indnullsnotdistinct"
    else SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"false"
  -- if partial, get constraint def
  SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pg_catalog.pg_get_expr(i.indpred, i.indrelid, true)"
  SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlJoinOn SQL
"pg_catalog.pg_index i" SQL
"c.oid = i.indexrelid"
  SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlJoinOn SQL
"pg_catalog.pg_am am" SQL
"c.relam = am.oid"
  SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlLeftJoinOn
    SQL
"pg_catalog.pg_constraint r"
    SQL
"r.conrelid = i.indrelid AND r.conindid = i.indexrelid"
  SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"i.indrelid" (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
  SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhereIsNULL SQL
"r.contype" -- fetch only "pure" indexes
  where
    -- Get all coordinates of the index.
    selectCoordinates :: m -> m -> m
selectCoordinates m
start m
end =
      [m] -> m
forall m. (IsString m, Monoid m) => [m] -> m
smconcat
        [ m
"WITH RECURSIVE coordinates(k, name) AS ("
        , m
"  VALUES (" m -> m -> m
forall a. Semigroup a => a -> a -> a
<> m
start m -> m -> m
forall a. Semigroup a => a -> a -> a
<> m
"::integer, NULL)"
        , m
"  UNION ALL"
        , m
"    SELECT k+1, pg_catalog.pg_get_indexdef(i.indexrelid, k+1, true)"
        , m
"      FROM coordinates"
        , m
"     WHERE k < " m -> m -> m
forall a. Semigroup a => a -> a -> a
<> m
end
        , m
")"
        , m
"SELECT name FROM coordinates WHERE name IS NOT NULL"
        ]

fetchTableIndex
  :: (String, Array1 String, Array1 String, String, Bool, Bool, Bool, Maybe String)
  -> (TableIndex, RawSQL ())
fetchTableIndex :: (String, Array1 String, Array1 String, String, Bool, Bool, Bool,
 Maybe String)
-> (TableIndex, RawSQL ())
fetchTableIndex (String
name, Array1 [String]
keyColumns, Array1 [String]
includeColumns, String
method, Bool
unique, Bool
valid, Bool
nullsNotDistinct, Maybe String
mconstraint) =
  ( TableIndex
      { idxColumns :: [IndexColumn]
idxColumns = (String -> IndexColumn) -> [String] -> [IndexColumn]
forall a b. (a -> b) -> [a] -> [b]
map (RawSQL () -> IndexColumn
indexColumn (RawSQL () -> IndexColumn)
-> (String -> RawSQL ()) -> String -> IndexColumn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL) [String]
keyColumns
      , idxInclude :: [RawSQL ()]
idxInclude = (String -> RawSQL ()) -> [String] -> [RawSQL ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL [String]
includeColumns
      , idxMethod :: IndexMethod
idxMethod = String -> IndexMethod
forall a. Read a => String -> a
read String
method
      , idxUnique :: Bool
idxUnique = Bool
unique
      , idxValid :: Bool
idxValid = Bool
valid
      , idxWhere :: Maybe (RawSQL ())
idxWhere = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL (String -> RawSQL ()) -> Maybe String -> Maybe (RawSQL ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
mconstraint
      , idxNotDistinctNulls :: Bool
idxNotDistinctNulls = Bool
nullsNotDistinct
      }
  , String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name
  )

-- *** FOREIGN KEYS ***

sqlGetForeignKeys :: Table -> SQL
sqlGetForeignKeys :: Table -> SQL
sqlGetForeignKeys Table
table = SqlSelect -> SQL
forall a. Sqlable a => a -> SQL
toSQLCommand
  (SqlSelect -> SQL)
-> (State SqlSelect () -> SqlSelect) -> State SqlSelect () -> SQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_constraint r"
  (State SqlSelect () -> SQL) -> State SqlSelect () -> SQL
forall a b. (a -> b) -> a -> b
$ do
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.conname::text" -- fk name
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$
      SQL
"ARRAY(SELECT a.attname::text FROM pg_catalog.pg_attribute a JOIN ("
        SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> RawSQL () -> SQL
unnestWithOrdinality RawSQL ()
"r.conkey"
        SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> SQL
") conkeys ON (a.attnum = conkeys.item) \
           \WHERE a.attrelid = r.conrelid \
           \ORDER BY conkeys.n)" -- constrained columns
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.relname::text" -- referenced table
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$
      SQL
"ARRAY(SELECT a.attname::text \
      \FROM pg_catalog.pg_attribute a JOIN ("
        SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> RawSQL () -> SQL
unnestWithOrdinality RawSQL ()
"r.confkey"
        SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> SQL
") confkeys ON (a.attnum = confkeys.item) \
           \WHERE a.attrelid = r.confrelid \
           \ORDER BY confkeys.n)" -- referenced columns
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.confupdtype" -- on update
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.confdeltype" -- on delete
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.condeferrable" -- deferrable?
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.condeferred" -- initially deferred?
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.convalidated" -- validated?
    SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlJoinOn SQL
"pg_catalog.pg_class c" SQL
"c.oid = r.confrelid"
    SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"r.conrelid" (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
    SQL -> Char -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"r.contype" Char
'f'
  where
    unnestWithOrdinality :: RawSQL () -> SQL
    unnestWithOrdinality :: RawSQL () -> SQL
unnestWithOrdinality RawSQL ()
arr =
      SQL
"SELECT n, "
        SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> RawSQL () -> SQL
raw RawSQL ()
arr
        SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> SQL
"[n] AS item FROM generate_subscripts("
        SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> RawSQL () -> SQL
raw RawSQL ()
arr
        SQL -> SQL -> SQL
forall a. Semigroup a => a -> a -> a
<> SQL
", 1) AS n"

fetchForeignKey
  :: (String, Array1 String, String, Array1 String, Char, Char, Bool, Bool, Bool)
  -> (ForeignKey, RawSQL ())
fetchForeignKey :: (String, Array1 String, String, Array1 String, Char, Char, Bool,
 Bool, Bool)
-> (ForeignKey, RawSQL ())
fetchForeignKey
  ( String
name
    , Array1 [String]
columns
    , String
reftable
    , Array1 [String]
refcolumns
    , Char
on_update
    , Char
on_delete
    , Bool
deferrable
    , Bool
deferred
    , Bool
validated
    ) =
    ( ForeignKey
        { fkColumns :: [RawSQL ()]
fkColumns = (String -> RawSQL ()) -> [String] -> [RawSQL ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL [String]
columns
        , fkRefTable :: RawSQL ()
fkRefTable = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
reftable
        , fkRefColumns :: [RawSQL ()]
fkRefColumns = (String -> RawSQL ()) -> [String] -> [RawSQL ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL [String]
refcolumns
        , fkOnUpdate :: ForeignKeyAction
fkOnUpdate = Char -> ForeignKeyAction
charToForeignKeyAction Char
on_update
        , fkOnDelete :: ForeignKeyAction
fkOnDelete = Char -> ForeignKeyAction
charToForeignKeyAction Char
on_delete
        , fkDeferrable :: Bool
fkDeferrable = Bool
deferrable
        , fkDeferred :: Bool
fkDeferred = Bool
deferred
        , fkValidated :: Bool
fkValidated = Bool
validated
        }
    , String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name
    )
    where
      charToForeignKeyAction :: Char -> ForeignKeyAction
charToForeignKeyAction Char
c = case Char
c of
        Char
'a' -> ForeignKeyAction
ForeignKeyNoAction
        Char
'r' -> ForeignKeyAction
ForeignKeyRestrict
        Char
'c' -> ForeignKeyAction
ForeignKeyCascade
        Char
'n' -> ForeignKeyAction
ForeignKeySetNull
        Char
'd' -> ForeignKeyAction
ForeignKeySetDefault
        Char
_ ->
          String -> ForeignKeyAction
forall a. HasCallStack => String -> a
error (String -> ForeignKeyAction) -> String -> ForeignKeyAction
forall a b. (a -> b) -> a -> b
$
            String
"fetchForeignKey: invalid foreign key action code: "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c