module Database.PostgreSQL.PQTypes.Checks (
  -- * Checks
    checkDatabase
  , createTable
  , createDomain

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

  -- * Migrations
  , migrateDatabase
  ) where

import Control.Arrow ((&&&))
import Control.Concurrent (threadDelay)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Reader
import Data.Int
import Data.Function
import Data.List (partition)
import Data.Maybe
import Data.Monoid.Utils
import Data.Ord (comparing)
import Data.Typeable (cast)
import qualified Data.String
import Data.Text (Text)
import Database.PostgreSQL.PQTypes
import GHC.Stack (HasCallStack)
import Log
import TextShow
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T

import Database.PostgreSQL.PQTypes.ExtrasOptions
import Database.PostgreSQL.PQTypes.Checks.Util
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 []    = forall a. HasCallStack => String -> a
error String
s
headExc String
_ (a
x:[a]
_) = a
x

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

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

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

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

  -- everything is OK, commit changes
  forall (m :: * -> *). 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.
checkDatabase
  :: forall m . (MonadDB m, MonadLog m, MonadThrow m)
  => ExtrasOptions
  -> [CompositeType]
  -> [Domain]
  -> [Table]
  -> m ()
checkDatabase :: forall (m :: * -> *).
(MonadDB m, MonadLog m, MonadThrow m) =>
ExtrasOptions -> [CompositeType] -> [Domain] -> [Table] -> m ()
checkDatabase ExtrasOptions
options [CompositeType]
composites [Domain]
domains [Table]
tables = do
  TablesWithVersions
tablesWithVersions <- forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Table] -> m TablesWithVersions
getTableVersions (Table
tableVersions forall a. a -> [a] -> [a]
: [Table]
tables)
  forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall a b. (a -> b) -> a -> b
$ ExtrasOptions -> TablesWithVersions -> ValidationResult
checkVersions ExtrasOptions
options TablesWithVersions
tablesWithVersions
  forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadDB m =>
TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> m ValidationResult
checkCompositesStructure TablesWithVersions
tablesWithVersions
                                           CompositesCreationMode
DontCreateComposites
                                           (ExtrasOptions -> ObjectsValidationMode
eoObjectsValidationMode ExtrasOptions
options)
                                           [CompositeType]
composites
  forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Domain] -> m ValidationResult
checkDomainsStructure [Domain]
domains
  forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
ExtrasOptions -> TablesWithVersions -> m ValidationResult
checkDBStructure ExtrasOptions
options TablesWithVersions
tablesWithVersions
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExtrasOptions -> ObjectsValidationMode
eoObjectsValidationMode ExtrasOptions
options forall a. Eq a => a -> a -> Bool
== ObjectsValidationMode
DontAllowUnknownObjects) forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkUnknownTables [Table]
tables
    forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkExistenceOfVersionsForTables (Table
tableVersions 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.
  forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Table] -> m ValidationResult
checkInitialSetups [Table]
tables

  where
    checkInitialSetups :: [Table] -> m ValidationResult
    checkInitialSetups :: [Table] -> m ValidationResult
checkInitialSetups [Table]
tbls =
      forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Table -> m ValidationResult
checkInitialSetup' forall a b. (a -> b) -> a -> b
$ [Table]
tbls

    checkInitialSetup' :: Table -> m ValidationResult
    checkInitialSetup' :: Table -> m ValidationResult
checkInitialSetup' t :: Table
t@Table{Int32
[Check]
[ForeignKey]
[TableIndex]
[Trigger]
[TableColumn]
Maybe PrimaryKey
Maybe TableInitialSetup
RawSQL ()
tblInitialSetup :: Table -> Maybe TableInitialSetup
tblTriggers :: Table -> [Trigger]
tblIndexes :: Table -> [TableIndex]
tblForeignKeys :: Table -> [ForeignKey]
tblChecks :: Table -> [Check]
tblPrimaryKey :: Table -> Maybe PrimaryKey
tblColumns :: Table -> [TableColumn]
tblVersion :: Table -> Int32
tblName :: Table -> RawSQL ()
tblInitialSetup :: Maybe TableInitialSetup
tblTriggers :: [Trigger]
tblIndexes :: [TableIndex]
tblForeignKeys :: [ForeignKey]
tblChecks :: [Check]
tblPrimaryKey :: Maybe PrimaryKey
tblColumns :: [TableColumn]
tblVersion :: Int32
tblName :: RawSQL ()
..} = case Maybe TableInitialSetup
tblInitialSetup of
      Maybe TableInitialSetup
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
      Just TableInitialSetup
is -> TableInitialSetup
-> forall (m :: * -> *). (MonadDB m, MonadThrow m) => m Bool
checkInitialSetup TableInitialSetup
is forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
        Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$ Text
"Initial setup for table '"
                 forall a. Semigroup a => a -> a -> a
<> Table -> Text
tblNameText Table
t forall a. Semigroup a => a -> a -> a
<> Text
"' is not valid"

-- | 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
  forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"SELECT current_catalog::text"
  String
dbname <- forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m t
fetchOne forall a. Identity a -> a
runIdentity
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL forall a b. (a -> b) -> a -> b
$ String
"\"" forall a. [a] -> [a] -> [a]
++ String
dbname 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
  forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall a b. (a -> b) -> a -> b
$ Text
"Checking for extension '" forall a. Semigroup a => a -> a -> a
<> Text
txtExtension forall a. Semigroup a => a -> a -> a
<> Text
"'"
  Bool
extensionExists <- forall sql (m :: * -> *).
(IsSQL sql, MonadDB m, MonadThrow m) =>
sql -> m Bool
runQuery01 forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_extension" forall a b. (a -> b) -> a -> b
$ do
    forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"TRUE"
    forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"extname" forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
unRawSQL RawSQL ()
extension
  if Bool -> Bool
not Bool
extensionExists
    then do
      forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall a b. (a -> b) -> a -> b
$ Text
"Creating extension '" forall a. Semigroup a => a -> a -> a
<> Text
txtExtension forall a. Semigroup a => a -> a -> a
<> Text
"'"
      forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ forall a b. (a -> b) -> a -> b
$ SQL
"CREATE EXTENSION IF NOT EXISTS" forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> SQL
raw RawSQL ()
extension
    else forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall a b. (a -> b) -> a -> b
$ Text
"Extension '" forall a. Semigroup a => a -> a -> a
<> Text
txtExtension 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
  forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"SHOW timezone"
  String
timezone :: String <- forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m t
fetchOne forall a. Identity a -> a
runIdentity
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
timezone forall a. Eq a => a -> a -> Bool
/= String
"UTC") forall a b. (a -> b) -> a -> b
$ do
    RawSQL ()
dbname <- forall (m :: * -> *). (MonadDB m, MonadThrow m) => m (RawSQL ())
currentCatalog
    forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall a b. (a -> b) -> a -> b
$ Text
"Setting '" forall a. Semigroup a => a -> a -> a
<> RawSQL () -> Text
unRawSQL RawSQL ()
dbname
      forall a. Semigroup a => a -> a -> a
<> Text
"' database to return timestamps in UTC"
    forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ RawSQL ()
"ALTER DATABASE" forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
dbname forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"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
  forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"information_schema.tables" forall a b. (a -> b) -> a -> b
$ do
    forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"table_name::text"
    forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"table_name <> 'table_versions'"
    forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"table_type = 'BASE TABLE'"
    forall v (m :: * -> *).
(MonadState v m, SqlWhere v) =>
SqlSelect -> m ()
sqlWhereExists forall a b. (a -> b) -> a -> b
$ SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"unnest(current_schemas(false)) as cs" forall a b. (a -> b) -> a -> b
$ do
      forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"TRUE"
      forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"cs = table_schema"

  [Text]
dbTableNames <- forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany forall a. Identity a -> a
runIdentity
  forall (m :: * -> *) a. Monad m => a -> m a
return [Text]
dbTableNames

checkVersions :: ExtrasOptions -> TablesWithVersions -> ValidationResult
checkVersions :: ExtrasOptions -> TablesWithVersions -> ValidationResult
checkVersions ExtrasOptions
options = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: Maybe TableInitialSetup
tblTriggers :: [Trigger]
tblIndexes :: [TableIndex]
tblForeignKeys :: [ForeignKey]
tblChecks :: [Check]
tblPrimaryKey :: Maybe PrimaryKey
tblColumns :: [TableColumn]
tblVersion :: Int32
tblName :: RawSQL ()
tblInitialSetup :: Table -> Maybe TableInitialSetup
tblTriggers :: Table -> [Trigger]
tblIndexes :: Table -> [TableIndex]
tblForeignKeys :: Table -> [ForeignKey]
tblChecks :: Table -> [Check]
tblPrimaryKey :: Table -> Maybe PrimaryKey
tblColumns :: Table -> [TableColumn]
tblVersion :: Table -> Int32
tblName :: Table -> RawSQL ()
..}, Int32
v)
      | if ExtrasOptions -> Bool
eoAllowHigherTableVersions ExtrasOptions
options
        then Int32
tblVersion forall a. Ord a => a -> a -> Bool
<= Int32
v
        else Int32
tblVersion forall a. Eq a => a -> a -> Bool
== Int32
v = forall a. Monoid a => a
mempty
      | Int32
v forall a. Eq a => a -> a -> Bool
== Int32
0    = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
                    Text
"Table '" forall a. Semigroup a => a -> a -> a
<> Table -> Text
tblNameText Table
t forall a. Semigroup a => a -> a -> a
<> Text
"' must be created"
      | Bool
otherwise = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
                    Text
"Table '" forall a. Semigroup a => a -> a -> a
<> Table -> Text
tblNameText Table
t
                    forall a. Semigroup a => a -> a -> a
<> Text
"' must be migrated" forall m. (IsString m, Monoid m) => m -> m -> m
<+> forall a. TextShow a => a -> Text
showt Int32
v forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"->"
                    forall m. (IsString m, Monoid m) => m -> m -> m
<+> 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  <- forall (m :: * -> *). MonadDB m => m [Text]
getDBTableNames
  let tableNames :: [Text]
tableNames = forall a b. (a -> b) -> [a] -> [b]
map (RawSQL () -> Text
unRawSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> RawSQL ()
tblName) [Table]
tables
      absent :: [Text]
absent     = [Text]
dbTableNames forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
tableNames
      notPresent :: [Text]
notPresent = [Text]
tableNames   forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
dbTableNames

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

validateIsNull :: Text -> [Text] -> ValidationResult
validateIsNull :: Text -> [Text] -> ValidationResult
validateIsNull Text
_   [] = forall a. Monoid a => a
mempty
validateIsNull Text
msg [Text]
ts = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$ Text
msg 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
  forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"table_versions" forall a b. (a -> b) -> a -> b
$ do
    forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"name::text"
  ([Text]
existingTableNames :: [Text]) <- forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany forall a. Identity a -> a
runIdentity

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

  if (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [Text]
absent) Bool -> Bool -> Bool
|| (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [Text]
notPresent)
    then do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. (IsString m, Monoid m) => m -> m -> m
(<+>) Text
"Unknown entry in 'table_versions':") [Text]
absent
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. (IsString m, Monoid m) => m -> m -> m
(<+>) Text
"Table not present in the 'table_versions':")
      [Text]
notPresent
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
      (Text -> [Text] -> ValidationResult
validateIsNull Text
"Unknown entry in table_versions':"  [Text]
absent ) forall a. Semigroup a => a -> a -> a
<>
      (Text -> [Text] -> ValidationResult
validateIsNull Text
"Tables not present in the 'table_versions':" [Text]
notPresent)
    else forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Domain]
defs forall a b. (a -> b) -> a -> b
$ \Domain
def -> do
  forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_type t1" forall a b. (a -> b) -> a -> b
$ do
    forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"t1.typname::text" -- name
    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
    forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"NOT t1.typnotnull" -- nullable
    forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"t1.typdefault" -- default value
    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.contypid = t1.oid ORDER by c.oid)" -- constraint names
    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.contypid = t1.oid \
              \ORDER by c.oid)" -- constraint definitions
    forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"ARRAY(SELECT c.convalidated FROM pg_catalog.pg_constraint c \
              \WHERE c.contypid = t1.oid \
              \ORDER by c.oid)" -- are constraints validated?
    forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"t1.typname" forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ Domain -> RawSQL ()
domName Domain
def
  Maybe Domain
mdom <- forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m (Maybe t)
fetchMaybe 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 = 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 = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
defval
      , domChecks :: Set Check
domChecks =
          [Check] -> Set Check
mkChecks forall a b. (a -> b) -> a -> b
$ forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3
          (\String
cname String
cond Bool
validated ->
             Check
             { chkName :: RawSQL ()
chkName = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
cname
             , chkCondition :: RawSQL ()
chkCondition = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
cond
             , chkValidated :: Bool
chkValidated = Bool
validated
             }) (forall a. Array1 a -> [a]
unArray1 Array1 String
cnames) (forall a. Array1 a -> [a]
unArray1 Array1 String
conds) (forall a. Array1 a -> [a]
unArray1 Array1 Bool
valids)
      }
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe Domain
mdom of
    Just Domain
dom
      | Domain
dom forall a. Eq a => a -> a -> Bool
/= Domain
def -> Text -> Text -> ValidationResult -> ValidationResult
topMessage Text
"domain" (RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ Domain -> RawSQL ()
domName Domain
dom) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [
          forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"name" Domain -> RawSQL ()
domName
        , forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"type" Domain -> ColumnType
domType
        , forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"nullable" Domain -> Bool
domNullable
        , forall a.
(Eq a, Show a) =>
Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult
compareAttr Domain
dom Domain
def Text
"default" Domain -> Maybe (RawSQL ())
domDefault
        , 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 -> forall a. Monoid a => a
mempty
    Maybe Domain
Nothing -> Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$ Text
"Domain '" forall a. Semigroup a => a -> a -> a
<> RawSQL () -> Text
unRawSQL (Domain -> RawSQL ()
domName Domain
def)
               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 forall a. Eq a => a -> a -> Bool
== Domain -> a
attr Domain
def = forall a. Monoid a => a
mempty
      | Bool
otherwise            = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
        Text
"Attribute '" forall a. Semigroup a => a -> a -> a
<> Text
attrname
        forall a. Semigroup a => a -> a -> a
<> Text
"' does not match (database:" forall m. (IsString m, Monoid m) => m -> m -> m
<+> String -> Text
T.pack (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Domain -> a
attr Domain
dom)
        forall a. Semigroup a => a -> a -> a
<> Text
", definition:" forall m. (IsString m, Monoid m) => m -> m -> m
<+> String -> Text
T.pack (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Domain -> a
attr Domain
def) forall a. Semigroup a => a -> a -> a
<> Text
")"

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

data CompositesCreationMode
  = CreateCompositesIfDatabaseEmpty
  | DontCreateComposites
  deriving CompositesCreationMode -> CompositesCreationMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CompositesCreationMode -> CompositesCreationMode -> Bool
$c/= :: CompositesCreationMode -> CompositesCreationMode -> Bool
== :: CompositesCreationMode -> CompositesCreationMode -> Bool
$c== :: 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 = forall (m :: * -> *). MonadDB m => m [CompositeType]
getDBCompositeTypes forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  [] | TablesWithVersions -> Bool
noTablesPresent TablesWithVersions
tablesWithVersions Bool -> Bool -> Bool
&& CompositesCreationMode
ccm forall a. Eq a => a -> a -> Bool
== CompositesCreationMode
CreateCompositesIfDatabaseEmpty -> do
         -- DB is not initialized, create composites if there are any defined.
         forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeType -> RawSQL ()
sqlCreateComposite) [CompositeType]
compositeList
         forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
  [CompositeType]
dbCompositeTypes -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
    [ ValidationResult
checkNotPresentComposites
    , ValidationResult
checkDatabaseComposites
    ]
    where
      compositeMap :: Map Text [CompositeColumn]
compositeMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map ((RawSQL () -> Text
unRawSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeType -> RawSQL ()
ctName) 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 = forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Set k
M.keysSet Map Text [CompositeColumn]
compositeMap
              forall a. Ord a => Set a -> Set a -> Set a
S.\\ forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> b) -> [a] -> [b]
map (RawSQL () -> Text
unRawSQL 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 = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> [a] -> [b]
`map` [CompositeType]
dbCompositeTypes) forall a b. (a -> b) -> a -> b
$ \CompositeType
dbComposite ->
        let cname :: Text
cname = RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ CompositeType -> RawSQL ()
ctName CompositeType
dbComposite
        in case Text
cname 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 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     -> forall a. Monoid a => a
mempty
            ObjectsValidationMode
DontAllowUnknownObjects -> Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
              [ Text
"Composite type '"
              , String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ 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
_ [] [] = forall a. Monoid a => a
mempty
          checkColumns Int
_ [CompositeColumn]
rest [] = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
            forall t. Show t => Text -> Text -> t -> Text
objectHasLess Text
"Composite type" Text
"columns" [CompositeColumn]
rest
          checkColumns Int
_ [] [CompositeColumn]
rest = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
            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) = forall a. Monoid a => [a] -> a
mconcat [
              Bool -> ValidationResult
validateNames forall a b. (a -> b) -> a -> b
$ CompositeColumn -> RawSQL ()
ccName CompositeColumn
d forall a. Eq a => a -> a -> Bool
== CompositeColumn -> RawSQL ()
ccName CompositeColumn
c
            , Bool -> ValidationResult
validateTypes forall a b. (a -> b) -> a -> b
$ CompositeColumn -> ColumnType
ccType CompositeColumn
d forall a. Eq a => a -> a -> Bool
== CompositeColumn -> ColumnType
ccType CompositeColumn
c
            , Int -> [CompositeColumn] -> [CompositeColumn] -> ValidationResult
checkColumns (Int
nforall a. Num a => a -> a -> a
+Int
1) [CompositeColumn]
defs [CompositeColumn]
cols
            ]
            where
              validateNames :: Bool -> ValidationResult
validateNames Bool
True  = forall a. Monoid a => a
mempty
              validateNames Bool
False = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
                Text -> Text -> (CompositeColumn -> Text) -> Text
errorMsg (Text
"no. " forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Text
showt Int
n) Text
"names" (RawSQL () -> Text
unRawSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeColumn -> RawSQL ()
ccName)

              validateTypes :: Bool -> ValidationResult
validateTypes Bool
True  = forall a. Monoid a => a
mempty
              validateTypes Bool
False = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
                Text -> Text -> (CompositeColumn -> Text) -> Text
errorMsg (RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ CompositeColumn -> RawSQL ()
ccName CompositeColumn
d) Text
"types" (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show 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 '" forall a. Semigroup a => a -> a -> a
<> Text
ident forall a. Semigroup a => a -> a -> a
<> Text
"' differs in"
                forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
attr forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"(database:" forall m. (IsString m, Monoid m) => m -> m -> m
<+> CompositeColumn -> Text
f CompositeColumn
c forall a. Semigroup a => a -> a -> a
<> Text
", definition:" forall m. (IsString m, Monoid m) => m -> m -> m
<+> CompositeColumn -> Text
f CompositeColumn
d 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM TablesWithVersions
tables 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) 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.
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if ExtrasOptions -> Bool
eoAllowHigherTableVersions ExtrasOptions
options Bool -> Bool -> Bool
&& Table -> Int32
tblVersion Table
table 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 :: Maybe TableInitialSetup
tblTriggers :: [Trigger]
tblIndexes :: [TableIndex]
tblForeignKeys :: [ForeignKey]
tblChecks :: [Check]
tblPrimaryKey :: Maybe PrimaryKey
tblColumns :: [TableColumn]
tblVersion :: Int32
tblName :: RawSQL ()
tblInitialSetup :: Table -> Maybe TableInitialSetup
tblTriggers :: Table -> [Trigger]
tblIndexes :: Table -> [TableIndex]
tblForeignKeys :: Table -> [ForeignKey]
tblChecks :: Table -> [Check]
tblPrimaryKey :: Table -> Maybe PrimaryKey
tblColumns :: Table -> [TableColumn]
tblVersion :: Table -> Int32
tblName :: Table -> RawSQL ()
..} = do
      -- get table description from pg_catalog as describeTable
      -- mechanism from HDBC doesn't give accurate results
      forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_attribute a" forall a b. (a -> b) -> a -> b
$ do
        forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"a.attname::text"
        forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pg_catalog.format_type(a.atttypid, a.atttypmod)"
        forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> SQL
parenthesize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Sqlable a => a -> SQL
toSQLCommand forall a b. (a -> b) -> a -> b
$
          SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_collation c, pg_catalog.pg_type t" forall a b. (a -> b) -> a -> b
$ do
            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.
            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"
        forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"NOT a.attnotnull"
        forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> SQL
parenthesize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Sqlable a => a -> SQL
toSQLCommand forall a b. (a -> b) -> a -> b
$
          SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_attrdef d" forall a b. (a -> b) -> a -> b
$ do
            forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pg_catalog.pg_get_expr(d.adbin, d.adrelid)"
            forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"d.adrelid = a.attrelid"
            forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"d.adnum = a.attnum"
            forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"a.atthasdef"
        forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"a.attnum > 0"
        forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"NOT a.attisdropped"
        forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"a.attrelid" forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
        forall v (m :: * -> *).
(MonadState v m, SqlOrderBy v) =>
SQL -> m ()
sqlOrderBy SQL
"a.attnum"
      [TableColumn]
desc <- forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, ColumnType, Maybe Text, Bool, Maybe String) -> TableColumn
fetchTableColumn
      -- get info about constraints from pg_catalog
      Maybe (PrimaryKey, RawSQL ())
pk <- forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
Table -> m (Maybe (PrimaryKey, RawSQL ()))
sqlGetPrimaryKey Table
table
      forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetChecks Table
table
      [Check]
checks <- forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, String, Bool) -> Check
fetchTableCheck
      forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetIndexes Table
table
      [(TableIndex, RawSQL ())]
indexes <- forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, Array1 String, Array1 String, String, Bool, Bool,
 Maybe String)
-> (TableIndex, RawSQL ())
fetchTableIndex
      forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetForeignKeys Table
table
      [(ForeignKey, RawSQL ())]
fkeys <- forall (m :: * -> *) row t.
(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 <- forall (m :: * -> *).
MonadDB m =>
RawSQL () -> m [(Trigger, RawSQL ())]
getDBTriggers RawSQL ()
tblName
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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
        , [Trigger] -> [(Trigger, RawSQL ())] -> ValidationResult
checkTriggers [Trigger]
tblTriggers [(Trigger, RawSQL ())]
triggers
        ]
      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 = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name
          , colType :: ColumnType
colType = ColumnType
ctype
          , colCollation :: Maybe (RawSQL ())
colCollation = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall row. (Show row, ToRow row) => Text -> row -> RawSQL row
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 = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Maybe String
mdefault
          }

        checkColumns
          :: Int -> [TableColumn] -> [TableColumn] -> ValidationResult
        checkColumns :: Int -> [TableColumn] -> [TableColumn] -> ValidationResult
checkColumns Int
_ [] [] = forall a. Monoid a => a
mempty
        checkColumns Int
_ [TableColumn]
rest [] = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
          forall t. Show t => Text -> Text -> t -> Text
objectHasLess Text
"Table" Text
"columns" [TableColumn]
rest
        checkColumns Int
_ [] [TableColumn]
rest = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
          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) = forall a. Monoid a => [a] -> a
mconcat [
            Bool -> ValidationResult
validateNames forall a b. (a -> b) -> a -> b
$ TableColumn -> RawSQL ()
colName TableColumn
d 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 forall a b. (a -> b) -> a -> b
$ TableColumn -> ColumnType
colType TableColumn
d forall a. Eq a => a -> a -> Bool
== TableColumn -> ColumnType
colType TableColumn
c Bool -> Bool -> Bool
||
            (TableColumn -> ColumnType
colType TableColumn
d forall a. Eq a => a -> a -> Bool
== ColumnType
BigSerialT Bool -> Bool -> Bool
&& TableColumn -> ColumnType
colType TableColumn
c 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 forall a b. (a -> b) -> a -> b
$ TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
d forall a. Eq a => a -> a -> Bool
== TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
c Bool -> Bool -> Bool
||
            (TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
d forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing
             Bool -> Bool -> Bool
&& ((Text -> Text -> Bool
T.isPrefixOf Text
"nextval('" forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
c)
                forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True)
          , Bool -> ValidationResult
validateNullables forall a b. (a -> b) -> a -> b
$ TableColumn -> Bool
colNullable TableColumn
d forall a. Eq a => a -> a -> Bool
== TableColumn -> Bool
colNullable TableColumn
c
          , Int -> [TableColumn] -> [TableColumn] -> ValidationResult
checkColumns (Int
nforall a. Num a => a -> a -> a
+Int
1) [TableColumn]
defs [TableColumn]
cols
          ]
          where
            validateNames :: Bool -> ValidationResult
validateNames Bool
True  = forall a. Monoid a => a
mempty
            validateNames Bool
False = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
              Text -> Text -> (TableColumn -> Text) -> Text
errorMsg (Text
"no. " forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Text
showt Int
n) Text
"names" (RawSQL () -> Text
unRawSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableColumn -> RawSQL ()
colName)

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

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

            validateDefaults :: Bool -> ValidationResult
validateDefaults Bool
True  = forall a. Monoid a => a
mempty
            validateDefaults Bool
False = Text -> ValidationResult
validationError forall a b. (a -> b) -> a -> b
$
              (Text -> Text -> (TableColumn -> Text) -> Text
errorMsg Text
cname Text
"defaults" (forall a. TextShow a => a -> Text
showt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RawSQL () -> Text
unRawSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableColumn -> Maybe (RawSQL ())
colDefault))
              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" forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
v
                  Maybe (RawSQL ())
Nothing -> RawSQL ()
"DROP DEFAULT"

            cname :: Text
cname = RawSQL () -> Text
unRawSQL 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 '" forall a. Semigroup a => a -> a -> a
<> Text
ident forall a. Semigroup a => a -> a -> a
<> Text
"' differs in"
              forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
attr forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"(table:" forall m. (IsString m, Monoid m) => m -> m -> m
<+> TableColumn -> Text
f TableColumn
c forall a. Semigroup a => a -> a -> a
<> Text
", definition:" forall m. (IsString m, Monoid m) => m -> m -> m
<+> TableColumn -> Text
f TableColumn
d forall a. Semigroup a => a -> a -> a
<> Text
")."
            sqlHint :: RawSQL () -> Text
sqlHint RawSQL ()
sql =
              Text
"(HINT: SQL for making the change is: ALTER TABLE"
              forall m. (IsString m, Monoid m) => m -> m -> m
<+> Table -> Text
tblNameText Table
table forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"ALTER COLUMN" forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
unRawSQL (TableColumn -> RawSQL ()
colName TableColumn
d)
              forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> Text
unRawSQL RawSQL ()
sql 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 = forall a. Monoid a => [a] -> a
mconcat [
            forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"PRIMARY KEY" [PrimaryKey]
def (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(PrimaryKey, RawSQL ())]
pk)
          , forall t.
Show t =>
(t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
checkNames (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 forall a. Monoid a => a
mempty
          ]
          where
            def :: [PrimaryKey]
def = forall a. Maybe a -> [a]
maybeToList Maybe PrimaryKey
mdef
            pk :: [(PrimaryKey, RawSQL ())]
pk = 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 forall a. a -> a
id forall {a}. IsString a => [a] -> [a]
mapErrs (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 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 = forall a. Monoid a => [a] -> a
mconcat
          forall a b. (a -> b) -> a -> b
$ forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"INDEXes" [TableIndex]
defs (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(TableIndex, RawSQL ())]
indexes)
          forall a. a -> [a] -> [a]
: forall t.
Show t =>
(t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
checkNames (RawSQL () -> TableIndex -> RawSQL ()
indexName RawSQL ()
tblName) [(TableIndex, RawSQL ())]
indexes
          forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Show a => (a, RawSQL ()) -> ValidationResult
localIndexInfo [(TableIndex, RawSQL ())]
localIndexes
          where
            localIndexInfo :: (a, RawSQL ()) -> ValidationResult
localIndexInfo (a
index, RawSQL ()
name) = Text -> ValidationResult
validationInfo 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 (forall a. Show a => a -> String
show a
index)
              ]

            ([(TableIndex, RawSQL ())]
localIndexes, [(TableIndex, RawSQL ())]
indexes) = (forall a. (a -> Bool) -> [a] -> ([a], [a])
`partition` [(TableIndex, RawSQL ())]
allIndexes) 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 = forall a. Monoid a => [a] -> a
mconcat [
            forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"FOREIGN KEYs" [ForeignKey]
defs (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(ForeignKey, RawSQL ())]
fkeys)
          , forall t.
Show t =>
(t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
checkNames (RawSQL () -> ForeignKey -> RawSQL ()
fkName RawSQL ()
tblName) [(ForeignKey, RawSQL ())]
fkeys
          ]

        checkTriggers :: [Trigger] -> [(Trigger, RawSQL ())] -> ValidationResult
        checkTriggers :: [Trigger] -> [(Trigger, RawSQL ())] -> ValidationResult
checkTriggers [Trigger]
defs [(Trigger, RawSQL ())]
triggers =
          ([Text] -> [Text])
-> ([Text] -> [Text]) -> ValidationResult -> ValidationResult
mapValidationResult forall a. a -> a
id forall {a}. IsString a => [a] -> [a]
mapErrs forall a b. (a -> b) -> a -> b
$ forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"TRIGGERs" [(Trigger, RawSQL ())]
defs' [(Trigger, RawSQL ())]
triggers
          where
            defs' :: [(Trigger, RawSQL ())]
defs' = forall a b. (a -> b) -> [a] -> [b]
map (\Trigger
t -> (Trigger
t, RawSQL () -> RawSQL ()
triggerFunctionMakeName forall a b. (a -> b) -> a -> b
$ Trigger -> RawSQL ()
triggerName Trigger
t)) [Trigger]
defs
            mapErrs :: [a] -> [a]
mapErrs []      = []
            mapErrs [a]
errmsgs = [a]
errmsgs 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.)"
              ]

-- | 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] -> TablesWithVersions -> [Migration m]
  -> m ()
checkDBConsistency :: forall (m :: * -> *).
(MonadIO m, MonadDB m, MonadLog m, MonadMask m) =>
ExtrasOptions
-> [Domain] -> TablesWithVersions -> [Migration m] -> m ()
checkDBConsistency ExtrasOptions
options [Domain]
domains TablesWithVersions
tablesWithVersions [Migration m]
migrations = do
  Bool
autoTransaction <- TransactionSettings -> Bool
tsAutoTransaction forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadDB m => m TransactionSettings
getTransactionSettings
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
autoTransaction forall a b. (a -> b) -> a -> b
$ do
    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 <- 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 = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst TablesWithVersions
tablesWithVersions

    errorInvalidMigrations :: HasCallStack => [RawSQL ()] -> a
    errorInvalidMigrations :: forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [RawSQL ()]
tblNames =
      forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"checkDBConsistency: invalid migrations for tables"
              forall m. (IsString m, Monoid m) => m -> m -> m
<+> (forall a. [a] -> [[a]] -> [a]
L.intercalate String
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack 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
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Int32]
presentMigrationVersions forall a. Eq a => a -> a -> Bool
/= [Int32]
expectedMigrationVersions) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention Text
"Migrations are invalid" forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [
            Key
"table"                       forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Table -> Text
tblNameText Table
table
          , Key
"migration_versions"          forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Int32]
presentMigrationVersions
          , Key
"expected_migration_versions" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Int32]
expectedMigrationVersions
          ]
        forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [Table -> RawSQL ()
tblName forall a b. (a -> b) -> a -> b
$ Table
table]

    validateMigrations :: m ()
    validateMigrations :: m ()
validateMigrations = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Table]
tables 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
mgrAction :: forall (m :: * -> *). Migration m -> MigrationAction m
mgrFrom :: forall (m :: * -> *). Migration m -> Int32
mgrAction :: MigrationAction m
mgrTableName :: RawSQL ()
mgrFrom :: Int32
mgrTableName :: forall (m :: * -> *). Migration m -> RawSQL ()
..} <- [Migration m]
migrations
                        , RawSQL ()
mgrTableName forall a. Eq a => a -> a -> Bool
== Table -> RawSQL ()
tblName Table
table ]
          expectedMigrationVersions :: [Int32]
expectedMigrationVersions
            = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int32]
presentMigrationVersions) forall a b. (a -> b) -> a -> b
$
              forall a. [a] -> [a]
reverse  [Int32
0 .. Table -> Int32
tblVersion Table
table 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 =
            [ forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName forall a b. (a -> b) -> a -> b
$ Migration m
mgr | Migration m
mgr <- [Migration m]
migrations
                                 , 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 = forall a. Eq a => [a] -> [a] -> [a]
L.intersect [RawSQL ()]
droppedTableNames [RawSQL ()]
tableNames
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [RawSQL ()]
intersection) forall a b. (a -> b) -> a -> b
$ do
          forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention (Text
"The intersection between tables "
                        forall a. Semigroup a => a -> a -> a
<> Text
"and dropped tables is not empty")
            forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
            [ Key
"intersection" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a b. (a -> b) -> [a] -> [b]
map RawSQL () -> Text
unRawSQL [RawSQL ()]
intersection ]
          forall a. HasCallStack => [RawSQL ()] -> a
errorInvalidMigrations [ Table -> RawSQL ()
tblName Table
tbl
                                 | Table
tbl <- [Table]
tables
                                 , Table -> RawSQL ()
tblName Table
tbl 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     = forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName)
                                  [Migration m]
migrations
          dropMigrationLists :: [[Migration m]]
dropMigrationLists    = [ [Migration m]
mgrs | [Migration m]
mgrs <- [[Migration m]]
migrationsByTable
                                         , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Migration m -> Bool
isDropTableMigration forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
last forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrs) Bool -> Bool -> Bool
||
                     (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall (m :: * -> *). Migration m -> Bool
isDropTableMigration forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrs) forall a. Ord a => a -> a -> Bool
> Int
1 ]

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

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

    initializeDB :: m ()
    initializeDB :: m ()
initializeDB = do
      forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Running initial setup for tables..."
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Table]
tables forall a b. (a -> b) -> a -> b
$ \Table
t -> case Table -> Maybe TableInitialSetup
tblInitialSetup Table
t of
        Maybe TableInitialSetup
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just TableInitialSetup
tis -> do
          forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall a b. (a -> b) -> a -> b
$ Text
"Initializing" forall m. (IsString m, Monoid m) => m -> m -> m
<+> Table -> Text
tblNameText Table
t forall a. Semigroup a => a -> a -> a
<> Text
"..."
          TableInitialSetup
-> forall (m :: * -> *). (MonadDB m, MonadThrow m) => m ()
initialSetup TableInitialSetup
tis
      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_
      = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(RawSQL (), Int32, Int32)]
tablesWithVersions_ forall a b. (a -> b) -> a -> b
$ \(RawSQL ()
tableName, Int32
expectedVer, Int32
actualVer) ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int32
expectedVer forall a. Eq a => a -> a -> Bool
/= Int32
actualVer) forall a b. (a -> b) -> a -> b
$
        case [ Migration m
m | m :: Migration m
m@Migration{Int32
RawSQL ()
MigrationAction m
mgrAction :: MigrationAction m
mgrFrom :: Int32
mgrTableName :: RawSQL ()
mgrAction :: forall (m :: * -> *). Migration m -> MigrationAction m
mgrFrom :: forall (m :: * -> *). Migration m -> Int32
mgrTableName :: forall (m :: * -> *). Migration m -> RawSQL ()
..} <- [Migration m]
migrations
                 , RawSQL ()
mgrTableName forall a. Eq a => a -> a -> Bool
== RawSQL ()
tableName ] of
          [] ->
            forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"checkDBConsistency: no migrations found for table '"
              forall a. [a] -> [a] -> [a]
++ (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ RawSQL ()
tableName) forall a. [a] -> [a] -> [a]
++ String
"', cannot migrate "
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int32
actualVer forall a. [a] -> [a] -> [a]
++ String
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int32
expectedVer
          (Migration m
m:[Migration m]
_) | forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
m forall a. Ord a => a -> a -> Bool
> Int32
actualVer ->
                  forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"checkDBConsistency: earliest migration for table '"
                    forall a. [a] -> [a] -> [a]
++ (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ RawSQL ()
tableName) forall a. [a] -> [a] -> [a]
++ String
"' is from version "
                    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
m) forall a. [a] -> [a] -> [a]
++ String
", cannot migrate "
                    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int32
actualVer forall a. [a] -> [a] -> [a]
++ String
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int32
expectedVer
                | Bool
otherwise -> 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, forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
mgr, forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int32
mver)
            | Migration m
mgr <- [Migration m]
migrations
            , forall (m :: * -> *). Migration m -> Bool
isDropTableMigration Migration m
mgr
            , let tblName :: RawSQL ()
tblName = forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr
            , let mver :: Maybe Int32
mver = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (RawSQL () -> Text
unRawSQL RawSQL ()
tblName) forall a b. (a -> b) -> a -> b
$ [(Text, Int32)]
dbTablesWithVersions
            , forall a. Maybe a -> Bool
isJust Maybe Int32
mver ]
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(RawSQL (), Int32, Int32)]
dbTablesToDropWithVersions forall a b. (a -> b) -> a -> b
$ \(RawSQL ()
tblName, Int32
fromVer, Int32
ver) ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int32
fromVer forall a. Eq a => a -> a -> Bool
/= Int32
ver) 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 = [ forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr | Migration m
mgr <- [Migration m]
migrations
                                                , forall (m :: * -> *). Migration m -> Bool
isDropTableMigration Migration m
mgr ]
          droppedEventually :: Migration m -> Bool
          droppedEventually :: Migration m -> Bool
droppedEventually Migration m
mgr = forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr 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 = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (RawSQL () -> Text
unRawSQL forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName Migration m
mgr)
                          [(Text, Int32)]
dbTablesWithVersions

          tableDoesNotExist :: Migration m -> Bool
tableDoesNotExist = forall a. Maybe a -> Bool
isNothing 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' = 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 forall a b. (a -> b) -> a -> b
$
                            (forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
mgr forall a. Eq a => a -> a -> Bool
== Int32
0) Bool -> Bool -> Bool
&&
                            (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Migration m -> Bool
droppedEventually 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 -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$
                             forall (m :: * -> *). Migration m -> Int32
mgrFrom Migration m
mgr 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                     = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Migration m]
migrationsToRun'
          initialMigrations :: [Migration m]
initialMigrations     = forall a. Int -> [a] -> [a]
drop Int
l forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Migration m]
migrations
          additionalMigrations' :: [Migration m]
additionalMigrations' = 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  = forall a. [a] -> [a]
reverse [Migration m]
additionalMigrations'
                grps :: [[Migration m]]
grps = forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName) [Migration m]
ret
            in if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
(/=) Int32
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Migration m -> Int32
mgrFrom forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [Migration m]
migrationsToRun'
                                  then [Migration m]
additionalMigrations 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
mgrAction :: MigrationAction m
mgrFrom :: Int32
mgrTableName :: RawSQL ()
mgrAction :: forall (m :: * -> *). Migration m -> MigrationAction m
mgrFrom :: forall (m :: * -> *). Migration m -> Int32
mgrTableName :: forall (m :: * -> *). Migration m -> RawSQL ()
..} = do
      case MigrationAction m
mgrAction of
        StandardMigration m ()
mgrDo -> do
          m ()
logMigration
          m ()
mgrDo
          m ()
updateTableVersion

        DropTableMigration DropTableMode
mgrDropTableMode -> do
          forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
arrListTable RawSQL ()
mgrTableName forall a. Semigroup a => a -> a -> a
<> Text
"drop table"
          forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ RawSQL () -> DropTableMode -> RawSQL ()
sqlDropTable RawSQL ()
mgrTableName
            DropTableMode
mgrDropTableMode
          forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ SQL -> State SqlDelete () -> SqlDelete
sqlDelete SQL
"table_versions" forall a b. (a -> b) -> a -> b
$ do
            forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"name" (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL 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.
          forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
bracket_ (forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"COMMIT") (forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"BEGIN") 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).
            forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ RawSQL ()
"DROP INDEX CONCURRENTLY IF EXISTS" forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> TableIndex -> RawSQL ()
indexName RawSQL ()
tname TableIndex
idx
            forall sql (m :: * -> *). (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.
          forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
bracket_ (forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"COMMIT") (forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"BEGIN") forall a b. (a -> b) -> a -> b
$ do
            forall sql (m :: * -> *). (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
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
batchSize forall a. Ord a => a -> a -> Bool
< Int
1000) forall a b. (a -> b) -> a -> b
$ do
            forall a. HasCallStack => String -> a
error String
"Batch size cannot be less than 1000"
          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 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 <- forall a. Ord a => a -> a -> a
max Int
1000 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Integral a => a -> a -> a
`div` Int32
20) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MonadDB m => RawSQL () -> m Int32
getRowEstimate RawSQL ()
tableName
            let cursorLoop :: Int -> m ()
cursorLoop Int
processed = do
                  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 <- forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany forall a. a -> a
id
                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [t]
primaryKeys) forall a b. (a -> b) -> a -> b
$ do
                    [t] -> m ()
updateSql [t]
primaryKeys
                    if Int
processed forall a. Num a => a -> a -> a
+ Int
batchSize forall a. Ord a => a -> a -> Bool
>= Int
vacuumThreshold
                    then do
                      forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
bracket_ (forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"COMMIT")
                               (forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"BEGIN")
                               (forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ RawSQL ()
"VACUUM" forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
tableName)
                      Int -> m ()
cursorLoop Int
0
                    else do
                      forall (m :: * -> *). MonadDB m => m ()
commit
                      Int -> m ()
cursorLoop (Int
processed forall a. Num a => a -> a -> a
+ Int
batchSize)
            Int -> m ()
cursorLoop Int
0
          m ()
updateTableVersion

      where
        logMigration :: m ()
logMigration = do
          forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
arrListTable RawSQL ()
mgrTableName
            forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Text
showt Int32
mgrFrom forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"->" forall m. (IsString m, Monoid m) => m -> m -> m
<+> forall a. TextShow a => a -> Text
showt (forall a. Enum a => a -> a
succ Int32
mgrFrom)

        updateTableVersion :: m ()
updateTableVersion = do
          forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ SQL -> State SqlUpdate () -> SqlUpdate
sqlUpdate SQL
"table_versions" forall a b. (a -> b) -> a -> b
$ do
            forall v (m :: * -> *) a.
(MonadState v m, SqlSet v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlSet SQL
"version"  (forall a. Enum a => a -> a
succ Int32
mgrFrom)
            forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"name" (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL 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
          forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_class" forall a b. (a -> b) -> a -> b
$ do
            forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"reltuples::integer"
            forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"relname" forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
unRawSQL RawSQL ()
tableName
          forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m t
fetchOne 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
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [Migration m]
migrationsToRun) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Running migrations..."
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Migration m]
migrationsToRun forall a b. (a -> b) -> a -> b
$ \Migration m
mgr -> forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \m ()
loop -> do
          let restartMigration :: String -> m ()
restartMigration String
query = do
                forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention Text
"Failed to acquire a lock" forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Key
"query" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
query]
                forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Restarting the migration shortly..."
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
1000000
                m ()
loop
          forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
handleJust DBException -> Maybe String
lockNotAvailable String -> m ()
restartMigration forall a b. (a -> b) -> a -> b
$ do
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ExtrasOptions -> Maybe Int
eoLockTimeoutMs ExtrasOptions
options) forall a b. (a -> b) -> a -> b
$ \Int
lockTimeout -> do
              forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ forall a b. (a -> b) -> a -> b
$ SQL
"SET LOCAL lock_timeout TO" forall m. (IsString m, Monoid m) => m -> m -> m
<+> Int -> SQL
intToSQL Int
lockTimeout
            Migration m -> m ()
runMigration Migration m
mgr forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` forall (m :: * -> *). MonadDB m => m ()
rollback
            forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ forall a b. (a -> b) -> a -> b
$ Text
"Committing migration changes..."
            forall (m :: * -> *). MonadDB m => m ()
commit
        forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Running migrations... done."
      where
        intToSQL :: Int -> SQL
        intToSQL :: Int -> SQL
intToSQL = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

        lockNotAvailable :: DBException -> Maybe String
        lockNotAvailable :: DBException -> Maybe String
lockNotAvailable DBException{e
sql
dbeQueryContext :: ()
dbeError :: ()
dbeError :: e
dbeQueryContext :: sql
..}
          | Just DetailedQueryError{String
Maybe Int
Maybe String
ErrorCode
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
qeSourceFunction :: Maybe String
qeSourceLine :: Maybe Int
qeSourceFile :: Maybe String
qeContext :: Maybe String
qeInternalQuery :: Maybe String
qeInternalPosition :: Maybe Int
qeStatementPosition :: Maybe Int
qeMessageHint :: Maybe String
qeMessageDetail :: Maybe String
qeMessagePrimary :: String
qeErrorCode :: ErrorCode
qeSeverity :: String
..} <- forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
dbeError
          , ErrorCode
qeErrorCode forall a. Eq a => a -> a -> Bool
== ErrorCode
LockNotAvailable = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show sql
dbeQueryContext
          | Bool
otherwise                       = 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 =
            forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName) forall a b. (a -> b) -> a -> b
$ -- NB: stable sort
            [Migration m]
migrationsToRun

          loc_common :: String
loc_common = String
"Database.PostgreSQL.PQTypes.Checks."
            forall a. [a] -> [a] -> [a]
++ String
"checkDBConsistency.validateMigrationsToRun"

          lookupDBTableVer :: [Migration m] -> Maybe Int32
          lookupDBTableVer :: [Migration m] -> Maybe Int32
lookupDBTableVer [Migration m]
mgrGroup =
            forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (RawSQL () -> Text
unRawSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> [a] -> a
headExc String
head_err
                    forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrGroup) [(Text, Int32)]
dbTablesWithVersions
            where
              head_err :: String
head_err = String
loc_common 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 = forall a. a -> Maybe a -> a
fromMaybe Int32
0 forall a b. (a -> b) -> a -> b
$ [Migration m] -> Maybe Int32
lookupDBTableVer [Migration m]
mgrGroup
            , Int32
dbTableVer forall a. Eq a => a -> a -> Bool
/= (forall (m :: * -> *). Migration m -> Int32
mgrFrom forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> [a] -> a
headExc String
head_err forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrGroup)
            ]
            where
              head_err :: String
head_err = String
loc_common
                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
            , forall a. Maybe a -> Bool
isNothing 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
            , forall (m :: * -> *). Migration m -> Bool
isDropTableMigration forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> [a] -> a
headExc String
head_err forall a b. (a -> b) -> a -> b
$ [Migration m]
mgrGroup
            ]
            where
              head_err :: String
head_err = String
loc_common
                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
            , forall (m :: * -> *). Migration m -> Int32
mgrFrom (forall a. String -> [a] -> a
headExc String
head_err [Migration m]
mgrGroup) forall a. Eq a => a -> a -> Bool
/= Int32
0
            ]
            where
              head_err :: String
head_err = String
loc_common
                forall a. [a] -> [a] -> [a]
++ String
".groupsNotStartingWithCreateTable: broken invariant"

          tblNames :: [[Migration m]] -> [RawSQL ()]
          tblNames :: [[Migration m]] -> [RawSQL ()]
tblNames [[Migration m]]
grps =
            [ forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> [a] -> a
headExc String
head_err 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 forall a. [a] -> [a] -> [a]
++ String
".tblNames: broken invariant"

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

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

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

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

-- | 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 =
  forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
  [ (\Maybe Int32
mver -> (Table
tbl, forall a. a -> Maybe a -> a
fromMaybe Int32
0 Maybe Int32
mver)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
(==) Int32
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall (m :: * -> *). MonadDB m => m [Text]
getDBTableNames
  forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
    [ (\Maybe Int32
mver -> (Text
name, forall a. a -> Maybe a -> a
fromMaybe Int32
0 Maybe Int32
mver)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- forall sql (m :: * -> *).
(IsSQL sql, MonadDB m, MonadThrow m) =>
sql -> m Bool
runQuery01 forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_class c" forall a b. (a -> b) -> a -> b
$ do
    forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"TRUE"
    forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlLeftJoinOn SQL
"pg_catalog.pg_namespace n" SQL
"n.oid = c.relnamespace"
    forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c.relname" forall a b. (a -> b) -> a -> b
$ String
tblName
    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
      forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall a b. (a -> b) -> a -> b
$ SQL
"SELECT version FROM table_versions WHERE name ="
        forall t. (Show t, ToSQL t) => SQL -> t -> SQL
<?> String
tblName
      Maybe Int32
mver <- forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m (Maybe t)
fetchMaybe forall a. Identity a -> a
runIdentity
      case Maybe Int32
mver of
        Just Int32
ver -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Int32
ver
        Maybe Int32
Nothing  -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"checkTableVersion: table '"
          forall a. [a] -> [a] -> [a]
++ String
tblName
          forall a. [a] -> [a] -> [a]
++ String
"' is present in the database, "
          forall a. [a] -> [a] -> [a]
++ String
"but there is no corresponding version info in 'table_versions'."
    else do
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- *** TABLE STRUCTURE ***

sqlGetTableID :: Table -> SQL
sqlGetTableID :: Table -> SQL
sqlGetTableID Table
table = SQL -> SQL
parenthesize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Sqlable a => a -> SQL
toSQLCommand forall a b. (a -> b) -> a -> b
$
  SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_class c" forall a b. (a -> b) -> a -> b
$ do
    forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.oid"
    forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlLeftJoinOn SQL
"pg_catalog.pg_namespace n" SQL
"n.oid = c.relnamespace"
    forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c.relname" forall a b. (a -> b) -> a -> b
$ Table -> String
tblNameString Table
table
    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
    forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_constraint" forall a b. (a -> b) -> a -> b
$ do
      forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"conkey"
      forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"conrelid" (Table -> SQL
sqlGetTableID Table
table)
      forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"contype" Char
'p'
    forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m (Maybe t)
fetchMaybe forall a b. (a -> b) -> a -> b
$ forall a. Array1 a -> [a]
unArray1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity

  case Maybe [Int16]
mColumnNumbers of
    Maybe [Int16]
Nothing -> do forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Just [Int16]
columnNumbers -> do
      [String]
columnNames <- do
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int16]
columnNumbers forall a b. (a -> b) -> a -> b
$ \Int16
k -> do
          forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pk_columns" forall a b. (a -> b) -> a -> b
$ do

            forall v (m :: * -> *) s.
(MonadState v m, SqlWith v, Sqlable s) =>
SQL -> s -> m ()
sqlWith SQL
"key_series" forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_constraint as c2" forall a b. (a -> b) -> a -> b
$ do
              forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"unnest(c2.conkey) as k"
              forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"c2.conrelid" forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
              forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c2.contype" Char
'p'

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

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

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

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

      forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) row t.
(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) = (, forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name)
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([RawSQL ()] -> Maybe PrimaryKey
pkOnColumns forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL [String]
columns)

-- *** CHECKS ***

sqlGetChecks :: Table -> SQL
sqlGetChecks :: Table -> SQL
sqlGetChecks Table
table = forall a. Sqlable a => a -> SQL
toSQLCommand forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_constraint c" forall a b. (a -> b) -> a -> b
$ do
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.conname::text"
  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
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.convalidated" -- validated?
  forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c.contype" Char
'c'
  forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"c.conrelid" 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 = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name
, chkCondition :: RawSQL ()
chkCondition = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
condition
, chkValidated :: Bool
chkValidated = Bool
validated
}

-- *** INDEXES ***

sqlGetIndexes :: Table -> SQL
sqlGetIndexes :: Table -> SQL
sqlGetIndexes Table
table = forall a. Sqlable a => a -> SQL
toSQLCommand forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_class c" forall a b. (a -> b) -> a -> b
$ do
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.relname::text" -- index name
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult forall a b. (a -> b) -> a -> b
$ SQL
"ARRAY(" forall a. Semigroup a => a -> a -> a
<> forall m. (IsString m, Monoid m) => m -> m -> m
selectCoordinates SQL
"0" SQL
"i.indnkeyatts" forall a. Semigroup a => a -> a -> a
<> SQL
")" -- array of key columns in the index
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult forall a b. (a -> b) -> a -> b
$ SQL
"ARRAY(" forall a. Semigroup a => a -> a -> a
<> forall m. (IsString m, Monoid m) => m -> m -> m
selectCoordinates SQL
"i.indnkeyatts" SQL
"i.indnatts" forall a. Semigroup a => a -> a -> a
<> SQL
")" -- array of included columns in the index
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"am.amname::text" -- the method used (btree, gin etc)
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"i.indisunique" -- is it unique?
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"i.indisvalid"  -- is it valid?
  -- if partial, get constraint def
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pg_catalog.pg_get_expr(i.indpred, i.indrelid, true)"
  forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlJoinOn SQL
"pg_catalog.pg_index i" SQL
"c.oid = i.indexrelid"
  forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlJoinOn SQL
"pg_catalog.pg_am am" SQL
"c.relam = am.oid"
  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"
  forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"i.indrelid" forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
  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 = forall m. (IsString m, Monoid m) => [m] -> m
smconcat [
        m
"WITH RECURSIVE coordinates(k, name) AS ("
      , m
"  VALUES (" forall a. Semigroup a => a -> a -> a
<> m
start 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 < " 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, Maybe String)
  -> (TableIndex, RawSQL ())
fetchTableIndex :: (String, Array1 String, Array1 String, String, Bool, Bool,
 Maybe String)
-> (TableIndex, RawSQL ())
fetchTableIndex (String
name, Array1 [String]
keyColumns, Array1 [String]
includeColumns, String
method, Bool
unique, Bool
valid, Maybe String
mconstraint) =
  (TableIndex
   { idxColumns :: [IndexColumn]
idxColumns = forall a b. (a -> b) -> [a] -> [b]
map (RawSQL () -> IndexColumn
indexColumn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL) [String]
keyColumns
   , idxInclude :: [RawSQL ()]
idxInclude = forall a b. (a -> b) -> [a] -> [b]
map forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL [String]
includeColumns
   , idxMethod :: IndexMethod
idxMethod = forall a. Read a => String -> a
read String
method
   , idxUnique :: Bool
idxUnique = Bool
unique
   , idxValid :: Bool
idxValid = Bool
valid
   , idxWhere :: Maybe (RawSQL ())
idxWhere = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Maybe String
mconstraint
   }
  , forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name)

-- *** FOREIGN KEYS ***

sqlGetForeignKeys :: Table -> SQL
sqlGetForeignKeys :: Table -> SQL
sqlGetForeignKeys Table
table = forall a. Sqlable a => a -> SQL
toSQLCommand
                          forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_constraint r" forall a b. (a -> b) -> a -> b
$ do
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.conname::text" -- fk name
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult forall a b. (a -> b) -> a -> b
$
    SQL
"ARRAY(SELECT a.attname::text FROM pg_catalog.pg_attribute a JOIN ("
    forall a. Semigroup a => a -> a -> a
<> RawSQL () -> SQL
unnestWithOrdinality RawSQL ()
"r.conkey"
    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
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.relname::text" -- referenced table
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult forall a b. (a -> b) -> a -> b
$ SQL
"ARRAY(SELECT a.attname::text \
              \FROM pg_catalog.pg_attribute a JOIN ("
    forall a. Semigroup a => a -> a -> a
<> RawSQL () -> SQL
unnestWithOrdinality RawSQL ()
"r.confkey"
    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
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.confupdtype" -- on update
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.confdeltype" -- on delete
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.condeferrable" -- deferrable?
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.condeferred" -- initially deferred?
  forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"r.convalidated" -- validated?
  forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlJoinOn SQL
"pg_catalog.pg_class c" SQL
"c.oid = r.confrelid"
  forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"r.conrelid" forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
  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, " forall a. Semigroup a => a -> a -> a
<> RawSQL () -> SQL
raw RawSQL ()
arr
      forall a. Semigroup a => a -> a -> a
<> SQL
"[n] AS item FROM generate_subscripts(" forall a. Semigroup a => a -> a -> a
<> RawSQL () -> SQL
raw RawSQL ()
arr 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 = forall a b. (a -> b) -> [a] -> [b]
map forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL [String]
columns
, fkRefTable :: RawSQL ()
fkRefTable = forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
reftable
, fkRefColumns :: [RawSQL ()]
fkRefColumns = forall a b. (a -> b) -> [a] -> [b]
map 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
}, 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
_   -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"fetchForeignKey: invalid foreign key action code: "
                     forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Char
c