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

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

  -- * Migrations
  , migrateDatabase
  ) where

import Control.Arrow ((&&&))
import Control.Applicative ((<$>))
import Control.Monad.Catch
import Control.Monad.Reader
import Data.Int
import Data.Function (on)
import Data.Maybe
import Data.Monoid
import Data.Monoid.Utils
import Data.Ord (comparing)
import qualified Data.String
import Data.Text (Text)
import Database.PostgreSQL.PQTypes
import GHC.Stack (HasCallStack)
import Log
import Prelude
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 :: String -> [a] -> a
headExc String
s []    = String -> a
forall a. HasCallStack => String -> a
error String
s
headExc String
_ (a
x:[a]
_) = a
x

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

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

  -- everything is OK, commit changes
  m ()
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 :: ExtrasOptions -> [CompositeType] -> [Domain] -> [Table] -> m ()
checkDatabase ExtrasOptions
options = ExtrasOptions
-> ObjectsValidationMode
-> [CompositeType]
-> [Domain]
-> [Table]
-> m ()
forall (m :: * -> *).
(MonadDB m, MonadLog m, MonadThrow m) =>
ExtrasOptions
-> ObjectsValidationMode
-> [CompositeType]
-> [Domain]
-> [Table]
-> m ()
checkDatabase_ ExtrasOptions
options ObjectsValidationMode
DontAllowUnknownObjects

-- | Same as 'checkDatabase', but will not fail if there are additional tables
-- and composite types in the database.
checkDatabaseAllowUnknownObjects
  :: forall m . (MonadDB m, MonadLog m, MonadThrow m)
  => ExtrasOptions -> [CompositeType] -> [Domain] -> [Table] -> m ()
checkDatabaseAllowUnknownObjects :: ExtrasOptions -> [CompositeType] -> [Domain] -> [Table] -> m ()
checkDatabaseAllowUnknownObjects ExtrasOptions
options = ExtrasOptions
-> ObjectsValidationMode
-> [CompositeType]
-> [Domain]
-> [Table]
-> m ()
forall (m :: * -> *).
(MonadDB m, MonadLog m, MonadThrow m) =>
ExtrasOptions
-> ObjectsValidationMode
-> [CompositeType]
-> [Domain]
-> [Table]
-> m ()
checkDatabase_ ExtrasOptions
options ObjectsValidationMode
AllowUnknownObjects

data ObjectsValidationMode = AllowUnknownObjects | DontAllowUnknownObjects
  deriving ObjectsValidationMode -> ObjectsValidationMode -> Bool
(ObjectsValidationMode -> ObjectsValidationMode -> Bool)
-> (ObjectsValidationMode -> ObjectsValidationMode -> Bool)
-> Eq ObjectsValidationMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ObjectsValidationMode -> ObjectsValidationMode -> Bool
$c/= :: ObjectsValidationMode -> ObjectsValidationMode -> Bool
== :: ObjectsValidationMode -> ObjectsValidationMode -> Bool
$c== :: ObjectsValidationMode -> ObjectsValidationMode -> Bool
Eq

checkDatabase_
  :: forall m . (MonadDB m, MonadLog m, MonadThrow m)
  => ExtrasOptions
  -> ObjectsValidationMode
  -> [CompositeType]
  -> [Domain]
  -> [Table]
  -> m ()
checkDatabase_ :: ExtrasOptions
-> ObjectsValidationMode
-> [CompositeType]
-> [Domain]
-> [Table]
-> m ()
checkDatabase_ ExtrasOptions
options ObjectsValidationMode
ovm [CompositeType]
composites [Domain]
domains [Table]
tables = do
  TablesWithVersions
tablesWithVersions <- [Table] -> m TablesWithVersions
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Table] -> m TablesWithVersions
getTableVersions (Table
tableVersions Table -> [Table] -> [Table]
forall a. a -> [a] -> [a]
: [Table]
tables)
  ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> ValidationResult -> m ()
forall a b. (a -> b) -> a -> b
$ TablesWithVersions -> ValidationResult
checkVersions TablesWithVersions
tablesWithVersions
  ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> m ValidationResult
forall (m :: * -> *).
MonadDB m =>
TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> m ValidationResult
checkCompositesStructure TablesWithVersions
tablesWithVersions CompositesCreationMode
DontCreateComposites ObjectsValidationMode
ovm [CompositeType]
composites
  ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Domain] -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
[Domain] -> m ValidationResult
checkDomainsStructure [Domain]
domains
  ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExtrasOptions -> TablesWithVersions -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
ExtrasOptions -> TablesWithVersions -> m ValidationResult
checkDBStructure ExtrasOptions
options TablesWithVersions
tablesWithVersions
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ObjectsValidationMode
ovm ObjectsValidationMode -> ObjectsValidationMode -> Bool
forall a. Eq a => a -> a -> Bool
== ObjectsValidationMode
DontAllowUnknownObjects) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Table] -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkUnknownTables [Table]
tables
    ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Table] -> m ValidationResult
forall (m :: * -> *).
(MonadDB m, MonadLog m) =>
[Table] -> m ValidationResult
checkExistenceOfVersionsForTables (Table
tableVersions Table -> [Table] -> [Table]
forall a. a -> [a] -> [a]
: [Table]
tables)

  -- Check initial setups only after database structure is considered
  -- consistent as before that some of the checks may fail internally.
  ValidationResult -> m ()
forall (m :: * -> *).
(MonadLog m, MonadThrow m) =>
ValidationResult -> m ()
resultCheck (ValidationResult -> m ()) -> m ValidationResult -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Table] -> m ValidationResult
checkInitialSetups [Table]
tables

  where
    checkVersions :: TablesWithVersions -> ValidationResult
    checkVersions :: TablesWithVersions -> ValidationResult
checkVersions TablesWithVersions
vs = [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat ([ValidationResult] -> ValidationResult)
-> (TablesWithVersions -> [ValidationResult])
-> TablesWithVersions
-> ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Table, Int32) -> ValidationResult)
-> TablesWithVersions -> [ValidationResult]
forall a b. (a -> b) -> [a] -> [b]
map (Table, Int32) -> ValidationResult
checkVersion (TablesWithVersions -> ValidationResult)
-> TablesWithVersions -> ValidationResult
forall a b. (a -> b) -> a -> b
$ TablesWithVersions
vs

    checkVersion :: (Table, Int32) -> ValidationResult
    checkVersion :: (Table, Int32) -> ValidationResult
checkVersion (t :: Table
t@Table{Int32
[Int32]
[Check]
[ForeignKey]
[TableIndex]
[TableColumn]
Maybe PrimaryKey
Maybe TableInitialSetup
RawSQL ()
tblInitialSetup :: Table -> Maybe TableInitialSetup
tblIndexes :: Table -> [TableIndex]
tblForeignKeys :: Table -> [ForeignKey]
tblChecks :: Table -> [Check]
tblPrimaryKey :: Table -> Maybe PrimaryKey
tblColumns :: Table -> [TableColumn]
tblAcceptedDbVersions :: Table -> [Int32]
tblVersion :: Table -> Int32
tblName :: Table -> RawSQL ()
tblInitialSetup :: Maybe TableInitialSetup
tblIndexes :: [TableIndex]
tblForeignKeys :: [ForeignKey]
tblChecks :: [Check]
tblPrimaryKey :: Maybe PrimaryKey
tblColumns :: [TableColumn]
tblAcceptedDbVersions :: [Int32]
tblVersion :: Int32
tblName :: RawSQL ()
..}, Int32
v)
      | Int32
tblVersion Int32 -> [Int32] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int32]
tblAcceptedDbVersions
                  = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
                    Text
"Table '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Table -> Text
tblNameText Table
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    Text
"' has its current table version in accepted db versions"
      | Int32
tblVersion Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
v Bool -> Bool -> Bool
|| Int32
v Int32 -> [Int32] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int32]
tblAcceptedDbVersions
                  = ValidationResult
forall a. Monoid a => a
mempty
      | Int32
v Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
0    = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
                    Text
"Table '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Table -> Text
tblNameText Table
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' must be created"
      | Bool
otherwise = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
                    Text
"Table '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Table -> Text
tblNameText Table
t
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' must be migrated" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Int32 -> Text
forall a. TextShow a => a -> Text
showt Int32
v Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"->"
                    Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Int32 -> Text
forall a. TextShow a => a -> Text
showt Int32
tblVersion

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

    checkInitialSetup' :: Table -> m ValidationResult
    checkInitialSetup' :: Table -> m ValidationResult
checkInitialSetup' t :: Table
t@Table{Int32
[Int32]
[Check]
[ForeignKey]
[TableIndex]
[TableColumn]
Maybe PrimaryKey
Maybe TableInitialSetup
RawSQL ()
tblInitialSetup :: Maybe TableInitialSetup
tblIndexes :: [TableIndex]
tblForeignKeys :: [ForeignKey]
tblChecks :: [Check]
tblPrimaryKey :: Maybe PrimaryKey
tblColumns :: [TableColumn]
tblAcceptedDbVersions :: [Int32]
tblVersion :: Int32
tblName :: RawSQL ()
tblInitialSetup :: Table -> Maybe TableInitialSetup
tblIndexes :: Table -> [TableIndex]
tblForeignKeys :: Table -> [ForeignKey]
tblChecks :: Table -> [Check]
tblPrimaryKey :: Table -> Maybe PrimaryKey
tblColumns :: Table -> [TableColumn]
tblAcceptedDbVersions :: Table -> [Int32]
tblVersion :: Table -> Int32
tblName :: Table -> RawSQL ()
..} = case Maybe TableInitialSetup
tblInitialSetup of
      Maybe TableInitialSetup
Nothing -> ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationResult
forall a. Monoid a => a
mempty
      Just TableInitialSetup
is -> TableInitialSetup
-> forall (m :: * -> *). (MonadDB m, MonadThrow m) => m Bool
checkInitialSetup TableInitialSetup
is m Bool -> (Bool -> m ValidationResult) -> m ValidationResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True  -> ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationResult
forall a. Monoid a => a
mempty
        Bool
False -> ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult -> m ValidationResult)
-> (Text -> ValidationResult) -> Text -> m ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ValidationResult
validationError (Text -> m ValidationResult) -> Text -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ Text
"Initial setup for table '"
                 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Table -> Text
tblNameText Table
t Text -> Text -> Text
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 :: m (RawSQL ())
currentCatalog = do
  SQL -> m ()
forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"SELECT current_catalog::text"
  String
dbname <- (Identity String -> String) -> m String
forall (m :: * -> *) row t.
(MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m t
fetchOne Identity String -> String
forall a. Identity a -> a
runIdentity
  RawSQL () -> m (RawSQL ())
forall (m :: * -> *) a. Monad m => a -> m a
return (RawSQL () -> m (RawSQL ())) -> RawSQL () -> m (RawSQL ())
forall a b. (a -> b) -> a -> b
$ String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL (String -> RawSQL ()) -> String -> RawSQL ()
forall a b. (a -> b) -> a -> b
$ String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dbname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""

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

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

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

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

-- | 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 :: [Table] -> m ValidationResult
checkUnknownTables [Table]
tables = do
  [Text]
dbTableNames  <- m [Text]
forall (m :: * -> *). MonadDB m => m [Text]
getDBTableNames
  let tableNames :: [Text]
tableNames = (Table -> Text) -> [Table] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (RawSQL () -> Text
unRawSQL (RawSQL () -> Text) -> (Table -> RawSQL ()) -> Table -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> RawSQL ()
tblName) [Table]
tables
      absent :: [Text]
absent     = [Text]
dbTableNames [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
tableNames
      notPresent :: [Text]
notPresent = [Text]
tableNames   [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
dbTableNames

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

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

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

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

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


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

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

data CompositesCreationMode
  = CreateCompositesIfDatabaseEmpty
  | DontCreateComposites
  deriving CompositesCreationMode -> CompositesCreationMode -> Bool
(CompositesCreationMode -> CompositesCreationMode -> Bool)
-> (CompositesCreationMode -> CompositesCreationMode -> Bool)
-> Eq CompositesCreationMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: 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 :: TablesWithVersions
-> CompositesCreationMode
-> ObjectsValidationMode
-> [CompositeType]
-> m ValidationResult
checkCompositesStructure TablesWithVersions
tablesWithVersions CompositesCreationMode
ccm ObjectsValidationMode
ovm [CompositeType]
compositeList = m [CompositeType]
forall (m :: * -> *). MonadDB m => m [CompositeType]
getDBCompositeTypes m [CompositeType]
-> ([CompositeType] -> m ValidationResult) -> m ValidationResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  [] | TablesWithVersions -> Bool
noTablesPresent TablesWithVersions
tablesWithVersions Bool -> Bool -> Bool
&& CompositesCreationMode
ccm CompositesCreationMode -> CompositesCreationMode -> Bool
forall a. Eq a => a -> a -> Bool
== CompositesCreationMode
CreateCompositesIfDatabaseEmpty -> do
         -- DB is not initialized, create composites if there are any defined.
         (CompositeType -> m ()) -> [CompositeType] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (RawSQL () -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (RawSQL () -> m ())
-> (CompositeType -> RawSQL ()) -> CompositeType -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeType -> RawSQL ()
sqlCreateComposite) [CompositeType]
compositeList
         ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationResult
forall a. Monoid a => a
mempty
  [CompositeType]
dbCompositeTypes -> ValidationResult -> m ValidationResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat
    [ ValidationResult
checkNotPresentComposites
    , ValidationResult
checkDatabaseComposites
    ]
    where
      compositeMap :: Map Text [CompositeColumn]
compositeMap = [(Text, [CompositeColumn])] -> Map Text [CompositeColumn]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, [CompositeColumn])] -> Map Text [CompositeColumn])
-> [(Text, [CompositeColumn])] -> Map Text [CompositeColumn]
forall a b. (a -> b) -> a -> b
$
        (CompositeType -> (Text, [CompositeColumn]))
-> [CompositeType] -> [(Text, [CompositeColumn])]
forall a b. (a -> b) -> [a] -> [b]
map ((RawSQL () -> Text
unRawSQL (RawSQL () -> Text)
-> (CompositeType -> RawSQL ()) -> CompositeType -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeType -> RawSQL ()
ctName) (CompositeType -> Text)
-> (CompositeType -> [CompositeColumn])
-> CompositeType
-> (Text, [CompositeColumn])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& CompositeType -> [CompositeColumn]
ctColumns) [CompositeType]
compositeList

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

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

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

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

-- | Checks whether the database is consistent.
checkDBStructure
  :: forall m. (MonadDB m, MonadThrow m)
  => ExtrasOptions
  -> TablesWithVersions
  -> m ValidationResult
checkDBStructure :: ExtrasOptions -> TablesWithVersions -> m ValidationResult
checkDBStructure ExtrasOptions
options TablesWithVersions
tables = ([ValidationResult] -> ValidationResult)
-> m [ValidationResult] -> m ValidationResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat (m [ValidationResult] -> m ValidationResult)
-> (((Table, Int32) -> m ValidationResult) -> m [ValidationResult])
-> ((Table, Int32) -> m ValidationResult)
-> m ValidationResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                  TablesWithVersions
-> ((Table, Int32) -> m ValidationResult) -> m [ValidationResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM TablesWithVersions
tables (((Table, Int32) -> m ValidationResult) -> m ValidationResult)
-> ((Table, Int32) -> m ValidationResult) -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ \(Table
table, Int32
version) ->
  do
  ValidationResult
result <- Text -> Text -> ValidationResult -> ValidationResult
topMessage Text
"table" (Table -> Text
tblNameText Table
table) (ValidationResult -> ValidationResult)
-> m ValidationResult -> m ValidationResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Table -> m ValidationResult
checkTableStructure Table
table
  -- If one of the accepted versions defined for the table is the current table
  -- version in the database, show inconsistencies as info messages only.
  ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ if Int32
version Int32 -> [Int32] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Table -> [Int32]
tblAcceptedDbVersions Table
table
           then ValidationResult -> ValidationResult
validationErrorsToInfos ValidationResult
result
           else ValidationResult
result
  where
    checkTableStructure :: Table -> m ValidationResult
    checkTableStructure :: Table -> m ValidationResult
checkTableStructure table :: Table
table@Table{Int32
[Int32]
[Check]
[ForeignKey]
[TableIndex]
[TableColumn]
Maybe PrimaryKey
Maybe TableInitialSetup
RawSQL ()
tblInitialSetup :: Maybe TableInitialSetup
tblIndexes :: [TableIndex]
tblForeignKeys :: [ForeignKey]
tblChecks :: [Check]
tblPrimaryKey :: Maybe PrimaryKey
tblColumns :: [TableColumn]
tblAcceptedDbVersions :: [Int32]
tblVersion :: Int32
tblName :: RawSQL ()
tblInitialSetup :: Table -> Maybe TableInitialSetup
tblIndexes :: Table -> [TableIndex]
tblForeignKeys :: Table -> [ForeignKey]
tblChecks :: Table -> [Check]
tblPrimaryKey :: Table -> Maybe PrimaryKey
tblColumns :: Table -> [TableColumn]
tblAcceptedDbVersions :: Table -> [Int32]
tblVersion :: Table -> Int32
tblName :: Table -> RawSQL ()
..} = do
      -- get table description from pg_catalog as describeTable
      -- mechanism from HDBC doesn't give accurate results
      SqlSelect -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SqlSelect -> m ()) -> SqlSelect -> m ()
forall a b. (a -> b) -> a -> b
$ SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_attribute a" (State SqlSelect () -> SqlSelect)
-> State SqlSelect () -> SqlSelect
forall a b. (a -> b) -> a -> b
$ do
        SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"a.attname::text"
        SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pg_catalog.format_type(a.atttypid, a.atttypmod)"
        SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"NOT a.attnotnull"
        SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult (SQL -> State SqlSelect ())
-> (SqlSelect -> SQL) -> SqlSelect -> State SqlSelect ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> SQL
parenthesize (SQL -> SQL) -> (SqlSelect -> SQL) -> SqlSelect -> SQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlSelect -> SQL
forall a. Sqlable a => a -> SQL
toSQLCommand (SqlSelect -> State SqlSelect ())
-> SqlSelect -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$
          SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_catalog.pg_attrdef d" (State SqlSelect () -> SqlSelect)
-> State SqlSelect () -> SqlSelect
forall a b. (a -> b) -> a -> b
$ do
            SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pg_catalog.pg_get_expr(d.adbin, d.adrelid)"
            SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"d.adrelid = a.attrelid"
            SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"d.adnum = a.attnum"
            SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"a.atthasdef"
        SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"a.attnum > 0"
        SQL -> State SqlSelect ()
forall v (m :: * -> *). (MonadState v m, SqlWhere v) => SQL -> m ()
sqlWhere SQL
"NOT a.attisdropped"
        SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *) sql.
(MonadState v m, SqlWhere v, Sqlable sql) =>
SQL -> sql -> m ()
sqlWhereEqSql SQL
"a.attrelid" (SQL -> State SqlSelect ()) -> SQL -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetTableID Table
table
        SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlOrderBy v) =>
SQL -> m ()
sqlOrderBy SQL
"a.attnum"
      [TableColumn]
desc <- ((String, ColumnType, Bool, Maybe String) -> TableColumn)
-> m [TableColumn]
forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, ColumnType, Bool, Maybe String) -> TableColumn
fetchTableColumn
      -- get info about constraints from pg_catalog
      Maybe (PrimaryKey, RawSQL ())
pk <- Table -> m (Maybe (PrimaryKey, RawSQL ()))
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
Table -> m (Maybe (PrimaryKey, RawSQL ()))
sqlGetPrimaryKey Table
table
      SQL -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SQL -> m ()) -> SQL -> m ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetChecks Table
table
      [Check]
checks <- ((String, String, Bool) -> Check) -> m [Check]
forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, String, Bool) -> Check
fetchTableCheck
      SQL -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SQL -> m ()) -> SQL -> m ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetIndexes Table
table
      [(TableIndex, RawSQL ())]
indexes <- ((String, Array1 String, String, Bool, Bool, Maybe String)
 -> (TableIndex, RawSQL ()))
-> m [(TableIndex, RawSQL ())]
forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, Array1 String, String, Bool, Bool, Maybe String)
-> (TableIndex, RawSQL ())
fetchTableIndex
      SQL -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SQL -> m ()) -> SQL -> m ()
forall a b. (a -> b) -> a -> b
$ Table -> SQL
sqlGetForeignKeys Table
table
      [(ForeignKey, RawSQL ())]
fkeys <- ((String, Array1 String, String, Array1 String, Char, Char, Bool,
  Bool, Bool)
 -> (ForeignKey, RawSQL ()))
-> m [(ForeignKey, RawSQL ())]
forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, Array1 String, String, Array1 String, Char, Char, Bool,
 Bool, Bool)
-> (ForeignKey, RawSQL ())
fetchForeignKey
      ValidationResult -> m ValidationResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidationResult -> m ValidationResult)
-> ValidationResult -> m ValidationResult
forall a b. (a -> b) -> a -> b
$ [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat [
          Int -> [TableColumn] -> [TableColumn] -> ValidationResult
checkColumns Int
1 [TableColumn]
tblColumns [TableColumn]
desc
        , Maybe PrimaryKey
-> Maybe (PrimaryKey, RawSQL ()) -> ValidationResult
checkPrimaryKey Maybe PrimaryKey
tblPrimaryKey Maybe (PrimaryKey, RawSQL ())
pk
        , [Check] -> [Check] -> ValidationResult
checkChecks [Check]
tblChecks [Check]
checks
        , [TableIndex] -> [(TableIndex, RawSQL ())] -> ValidationResult
checkIndexes [TableIndex]
tblIndexes [(TableIndex, RawSQL ())]
indexes
        , [ForeignKey] -> [(ForeignKey, RawSQL ())] -> ValidationResult
checkForeignKeys [ForeignKey]
tblForeignKeys [(ForeignKey, RawSQL ())]
fkeys
        ]
      where
        fetchTableColumn
          :: (String, ColumnType, Bool, Maybe String) -> TableColumn
        fetchTableColumn :: (String, ColumnType, Bool, Maybe String) -> TableColumn
fetchTableColumn (String
name, ColumnType
ctype, Bool
nullable, Maybe String
mdefault) = TableColumn :: RawSQL () -> ColumnType -> Bool -> Maybe (RawSQL ()) -> TableColumn
TableColumn {
            colName :: RawSQL ()
colName = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name
          , colType :: ColumnType
colType = ColumnType
ctype
          , colNullable :: Bool
colNullable = Bool
nullable
          , colDefault :: Maybe (RawSQL ())
colDefault = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL (String -> RawSQL ()) -> Maybe String -> Maybe (RawSQL ())
forall (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
_ [] [] = ValidationResult
forall a. Monoid a => a
mempty
        checkColumns Int
_ [TableColumn]
rest [] = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
          Text -> Text -> [TableColumn] -> Text
forall t. Show t => Text -> Text -> t -> Text
objectHasLess Text
"Table" Text
"columns" [TableColumn]
rest
        checkColumns Int
_ [] [TableColumn]
rest = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
          Text -> Text -> [TableColumn] -> Text
forall t. Show t => Text -> Text -> t -> Text
objectHasMore Text
"Table" Text
"columns" [TableColumn]
rest
        checkColumns !Int
n (TableColumn
d:[TableColumn]
defs) (TableColumn
c:[TableColumn]
cols) = [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat [
            Bool -> ValidationResult
validateNames (Bool -> ValidationResult) -> Bool -> ValidationResult
forall a b. (a -> b) -> a -> b
$ TableColumn -> RawSQL ()
colName TableColumn
d RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
== TableColumn -> RawSQL ()
colName TableColumn
c
          -- bigserial == bigint + autoincrement and there is no
          -- distinction between them after table is created.
          , Bool -> ValidationResult
validateTypes (Bool -> ValidationResult) -> Bool -> ValidationResult
forall a b. (a -> b) -> a -> b
$ TableColumn -> ColumnType
colType TableColumn
d ColumnType -> ColumnType -> Bool
forall a. Eq a => a -> a -> Bool
== TableColumn -> ColumnType
colType TableColumn
c Bool -> Bool -> Bool
||
            (TableColumn -> ColumnType
colType TableColumn
d ColumnType -> ColumnType -> Bool
forall a. Eq a => a -> a -> Bool
== ColumnType
BigSerialT Bool -> Bool -> Bool
&& TableColumn -> ColumnType
colType TableColumn
c ColumnType -> ColumnType -> Bool
forall a. Eq a => a -> a -> Bool
== ColumnType
BigIntT)
          -- There is a problem with default values determined by
          -- sequences as they're implicitly specified by db, so
          -- let's omit them in such case.
          , Bool -> ValidationResult
validateDefaults (Bool -> ValidationResult) -> Bool -> ValidationResult
forall a b. (a -> b) -> a -> b
$ TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
d Maybe (RawSQL ()) -> Maybe (RawSQL ()) -> Bool
forall a. Eq a => a -> a -> Bool
== TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
c Bool -> Bool -> Bool
||
            (TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
d Maybe (RawSQL ()) -> Maybe (RawSQL ()) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (RawSQL ())
forall a. Maybe a
Nothing
             Bool -> Bool -> Bool
&& ((Text -> Text -> Bool
T.isPrefixOf Text
"nextval('" (Text -> Bool) -> (RawSQL () -> Text) -> RawSQL () -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL) (RawSQL () -> Bool) -> Maybe (RawSQL ()) -> Maybe Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` TableColumn -> Maybe (RawSQL ())
colDefault TableColumn
c)
                Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
          , Bool -> ValidationResult
validateNullables (Bool -> ValidationResult) -> Bool -> ValidationResult
forall a b. (a -> b) -> a -> b
$ TableColumn -> Bool
colNullable TableColumn
d Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== TableColumn -> Bool
colNullable TableColumn
c
          , Int -> [TableColumn] -> [TableColumn] -> ValidationResult
checkColumns (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [TableColumn]
defs [TableColumn]
cols
          ]
          where
            validateNames :: Bool -> ValidationResult
validateNames Bool
True  = ValidationResult
forall a. Monoid a => a
mempty
            validateNames Bool
False = Text -> ValidationResult
validationError (Text -> ValidationResult) -> Text -> ValidationResult
forall a b. (a -> b) -> a -> b
$
              Text -> Text -> (TableColumn -> Text) -> Text
errorMsg (Text
"no. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
n) Text
"names" (RawSQL () -> Text
unRawSQL (RawSQL () -> Text)
-> (TableColumn -> RawSQL ()) -> TableColumn -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableColumn -> RawSQL ()
colName)

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

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

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

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

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

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

        checkIndexes :: [TableIndex] -> [(TableIndex, RawSQL ())]
                     -> ValidationResult
        checkIndexes :: [TableIndex] -> [(TableIndex, RawSQL ())] -> ValidationResult
checkIndexes [TableIndex]
defs [(TableIndex, RawSQL ())]
indexes = [ValidationResult] -> ValidationResult
forall a. Monoid a => [a] -> a
mconcat [
            Text -> [TableIndex] -> [TableIndex] -> ValidationResult
forall t. (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult
checkEquality Text
"INDEXes" [TableIndex]
defs (((TableIndex, RawSQL ()) -> TableIndex)
-> [(TableIndex, RawSQL ())] -> [TableIndex]
forall a b. (a -> b) -> [a] -> [b]
map (TableIndex, RawSQL ()) -> TableIndex
forall a b. (a, b) -> a
fst [(TableIndex, RawSQL ())]
indexes)
          , (TableIndex -> RawSQL ())
-> [(TableIndex, RawSQL ())] -> ValidationResult
forall t.
Show t =>
(t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult
checkNames (RawSQL () -> TableIndex -> RawSQL ()
indexName RawSQL ()
tblName) [(TableIndex, RawSQL ())]
indexes
          ]

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

-- | 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. (MonadDB m, MonadLog m, MonadMask m)
  => ExtrasOptions -> [Domain] -> TablesWithVersions -> [Migration m]
  -> m ()
checkDBConsistency :: ExtrasOptions
-> [Domain] -> TablesWithVersions -> [Migration m] -> m ()
checkDBConsistency ExtrasOptions
options [Domain]
domains TablesWithVersions
tablesWithVersions [Migration m]
migrations = do
  Bool
autoTransaction <- TransactionSettings -> Bool
tsAutoTransaction (TransactionSettings -> Bool) -> m TransactionSettings -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m TransactionSettings
forall (m :: * -> *). MonadDB m => m TransactionSettings
getTransactionSettings
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
autoTransaction (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    String -> m ()
forall a. HasCallStack => String -> a
error String
"checkDBConsistency: tsAutoTransaction setting needs to be True"
  -- Check the validity of the migrations list.
  m ()
validateMigrations
  m ()
validateDropTableMigrations

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

  if TablesWithVersions -> Bool
noTablesPresent TablesWithVersions
tablesWithVersions

    -- No tables are present, create everything from scratch.
    then do
      m ()
createDBSchema
      m ()
initializeDB

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

  where
    tables :: [Table]
tables = ((Table, Int32) -> Table) -> TablesWithVersions -> [Table]
forall a b. (a -> b) -> [a] -> [b]
map (Table, Int32) -> Table
forall a b. (a, b) -> a
fst TablesWithVersions
tablesWithVersions

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

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

    validateMigrations :: m ()
    validateMigrations :: m ()
validateMigrations = [Table] -> (Table -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Table]
tables ((Table -> m ()) -> m ()) -> (Table -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Table
table -> do
      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 RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
== Table -> RawSQL ()
tblName Table
table ]
          expectedMigrationVersions :: [Int32]
expectedMigrationVersions
            = [Int32] -> [Int32]
forall a. [a] -> [a]
reverse ([Int32] -> [Int32]) -> [Int32] -> [Int32]
forall a b. (a -> b) -> a -> b
$ Int -> [Int32] -> [Int32]
forall a. Int -> [a] -> [a]
take ([Int32] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int32]
presentMigrationVersions) ([Int32] -> [Int32]) -> [Int32] -> [Int32]
forall a b. (a -> b) -> a -> b
$
              [Int32] -> [Int32]
forall a. [a] -> [a]
reverse  [Int32
0 .. Table -> Int32
tblVersion Table
table Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
1]
      Table -> [Int32] -> [Int32] -> m ()
checkMigrationsListValidity Table
table [Int32]
presentMigrationVersions
        [Int32]
expectedMigrationVersions

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

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

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

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

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

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

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

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

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

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

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

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

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

    runMigration :: (Migration m) -> m ()
    runMigration :: Migration m -> m ()
runMigration Migration{Int32
RawSQL ()
MigrationAction m
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
          Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
arrListTable RawSQL ()
mgrTableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"drop table"
          RawSQL () -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (RawSQL () -> m ()) -> RawSQL () -> m ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> DropTableMode -> RawSQL ()
sqlDropTable RawSQL ()
mgrTableName
            DropTableMode
mgrDropTableMode
          SqlDelete -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (SqlDelete -> m ()) -> SqlDelete -> m ()
forall a b. (a -> b) -> a -> b
$ SQL -> State SqlDelete () -> SqlDelete
sqlDelete SQL
"table_versions" (State SqlDelete () -> SqlDelete)
-> State SqlDelete () -> SqlDelete
forall a b. (a -> b) -> a -> b
$ do
            SQL -> String -> State SqlDelete ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"name" (Text -> String
T.unpack (Text -> String) -> (RawSQL () -> Text) -> RawSQL () -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSQL () -> Text
unRawSQL (RawSQL () -> String) -> RawSQL () -> String
forall a b. (a -> b) -> a -> b
$ RawSQL ()
mgrTableName)

        CreateIndexConcurrentlyMigration RawSQL ()
tname TableIndex
idx -> do
          m ()
logMigration
          -- If migration was run before but creation of an index failed, index
          -- will be left in the database in an inactive state, so when we
          -- rerun, we need to remove it first (see
          -- https://www.postgresql.org/docs/9.6/sql-createindex.html for more
          -- information).
          RawSQL () -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (RawSQL () -> m ()) -> RawSQL () -> m ()
forall a b. (a -> b) -> a -> b
$ RawSQL ()
"DROP INDEX IF EXISTS" RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> TableIndex -> RawSQL ()
indexName RawSQL ()
tname TableIndex
idx
          -- 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.
          SQL -> m ()
forall (m :: * -> *). MonadDB m => SQL -> m ()
runSQL_ SQL
"COMMIT"
          RawSQL () -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (RawSQL () -> TableIndex -> RawSQL ()
sqlCreateIndexConcurrently RawSQL ()
tname TableIndex
idx) m () -> m () -> m ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` m ()
forall (m :: * -> *). MonadDB m => m ()
begin
          m ()
updateTableVersion
      where
        logMigration :: m ()
logMigration = do
          Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
arrListTable RawSQL ()
mgrTableName
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int32 -> Text
forall a. TextShow a => a -> Text
showt Int32
mgrFrom Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Text
"->" Text -> Text -> Text
forall m. (IsString m, Monoid m) => m -> m -> m
<+> Int32 -> Text
forall a. TextShow a => a -> Text
showt (Int32 -> Int32
forall a. Enum a => a -> a
succ Int32
mgrFrom)

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

    runMigrations :: [(Text, Int32)] -> m ()
    runMigrations :: [(Text, Int32)] -> m ()
runMigrations [(Text, Int32)]
dbTablesWithVersions = do
      let migrationsToRun :: [Migration m]
migrationsToRun = [(Text, Int32)] -> [Migration m]
findMigrationsToRun [(Text, Int32)]
dbTablesWithVersions
      [Migration m] -> [(Text, Int32)] -> m ()
validateMigrationsToRun [Migration m]
migrationsToRun [(Text, Int32)]
dbTablesWithVersions
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> ([Migration m] -> Bool) -> [Migration m] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Migration m] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Migration m] -> Bool) -> [Migration m] -> Bool
forall a b. (a -> b) -> a -> b
$ [Migration m]
migrationsToRun) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Running migrations..."
        [Migration m] -> (Migration m -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Migration m]
migrationsToRun ((Migration m -> m ()) -> m ()) -> (Migration m -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Migration m
mgr -> do
          Migration m -> m ()
runMigration Migration m
mgr

          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExtrasOptions -> Bool
eoForceCommit ExtrasOptions
options) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Committing migration changes..."
            m ()
forall (m :: * -> *). MonadDB m => m ()
commit
            Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Committing migration changes done."
            Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"!IMPORTANT! Database has been permanently changed"
        Text -> m ()
forall (m :: * -> *). MonadLog m => Text -> m ()
logInfo_ Text
"Running migrations... done."

    validateMigrationsToRun :: [Migration m] -> [(Text, Int32)] -> m ()
    validateMigrationsToRun :: [Migration m] -> [(Text, Int32)] -> m ()
validateMigrationsToRun [Migration m]
migrationsToRun [(Text, Int32)]
dbTablesWithVersions = do

      let migrationsToRunGrouped :: [[Migration m]]
          migrationsToRunGrouped :: [[Migration m]]
migrationsToRunGrouped =
            (Migration m -> Migration m -> Bool)
-> [Migration m] -> [[Migration m]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
(==) (RawSQL () -> RawSQL () -> Bool)
-> (Migration m -> RawSQL ()) -> Migration m -> Migration m -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName) ([Migration m] -> [[Migration m]])
-> ([Migration m] -> [Migration m])
-> [Migration m]
-> [[Migration m]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            (Migration m -> Migration m -> Ordering)
-> [Migration m] -> [Migration m]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy ((Migration m -> RawSQL ())
-> Migration m -> Migration m -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Migration m -> RawSQL ()
forall (m :: * -> *). Migration m -> RawSQL ()
mgrTableName) ([Migration m] -> [[Migration m]])
-> [Migration m] -> [[Migration m]]
forall a b. (a -> b) -> a -> b
$ -- NB: stable sort
            [Migration m]
migrationsToRun

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

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

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

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

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

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

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

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

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

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

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

-- | 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 :: [Table] -> m TablesWithVersions
getTableVersions [Table]
tbls =
  [m (Table, Int32)] -> m TablesWithVersions
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
  [ (\Maybe Int32
mver -> (Table
tbl, Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 Maybe Int32
mver)) (Maybe Int32 -> (Table, Int32))
-> m (Maybe Int32) -> m (Table, Int32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m (Maybe Int32)
forall (m :: * -> *).
(MonadDB m, MonadThrow m) =>
String -> m (Maybe Int32)
checkTableVersion (Table -> String
tblNameString Table
tbl)
  | Table
tbl <- [Table]
tbls ]

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

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

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

-- *** TABLE STRUCTURE ***

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

-- *** PRIMARY KEY ***

sqlGetPrimaryKey
  :: (MonadDB m, MonadThrow m)
  => Table -> m (Maybe (PrimaryKey, RawSQL ()))
sqlGetPrimaryKey :: Table -> m (Maybe (PrimaryKey, RawSQL ()))
sqlGetPrimaryKey Table
table = do

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

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

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

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

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

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

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

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

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

-- *** CHECKS ***

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

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

-- *** INDEXES ***

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

fetchTableIndex :: (String, Array1 String, String, Bool, Bool, Maybe String)
                -> (TableIndex, RawSQL ())
fetchTableIndex :: (String, Array1 String, String, Bool, Bool, Maybe String)
-> (TableIndex, RawSQL ())
fetchTableIndex (String
name, Array1 [String]
columns, String
method, Bool
unique, Bool
valid, Maybe String
mconstraint) =
  (TableIndex :: [RawSQL ()]
-> IndexMethod -> Bool -> Bool -> Maybe (RawSQL ()) -> TableIndex
TableIndex
   { idxColumns :: [RawSQL ()]
idxColumns = (String -> RawSQL ()) -> [String] -> [RawSQL ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL [String]
columns
   , idxMethod :: IndexMethod
idxMethod = String -> IndexMethod
forall a. Read a => String -> a
read String
method
   , idxUnique :: Bool
idxUnique = Bool
unique
   , idxValid :: Bool
idxValid = Bool
valid
   , idxWhere :: Maybe (RawSQL ())
idxWhere = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL (String -> RawSQL ()) -> Maybe String -> Maybe (RawSQL ())
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Maybe String
mconstraint
   }
  , String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
name)

-- *** FOREIGN KEYS ***

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

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