diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +# hpqtypes-extras-1.8.0.0 (2019-04-30) +* Make composite types subject to migration process + ([#21](https://github.com/scrive/hpqtypes-extras/pull/21)). +* Add migration type for concurrent creation of an index + ([#21](https://github.com/scrive/hpqtypes-extras/pull/21)). + # hpqtypes-extras-1.7.1.0 (2019-02-04) * Fix an issue where unnecessary migrations were run sometimes ([#18](https://github.com/scrive/hpqtypes-extras/pull/18)). diff --git a/hpqtypes-extras.cabal b/hpqtypes-extras.cabal --- a/hpqtypes-extras.cabal +++ b/hpqtypes-extras.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: hpqtypes-extras -version: 1.7.1.0 +version: 1.8.0.0 synopsis: Extra utilities for hpqtypes library description: The following extras for hpqtypes library: . @@ -20,7 +20,7 @@ copyright: Scrive AB category: Database build-type: Simple -tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3 +tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5 Source-repository head Type: git diff --git a/src/Database/PostgreSQL/PQTypes/Checks.hs b/src/Database/PostgreSQL/PQTypes/Checks.hs --- a/src/Database/PostgreSQL/PQTypes/Checks.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks.hs @@ -12,6 +12,7 @@ , migrateDatabase ) where +import Control.Arrow ((&&&)) import Control.Applicative ((<$>)) import Control.Monad.Catch import Control.Monad.Reader @@ -29,6 +30,8 @@ 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 @@ -46,16 +49,22 @@ -- | Run migrations and check the database structure. migrateDatabase - :: (MonadDB m, MonadLog m, MonadThrow m) - => ExtrasOptions -> [Extension] -> [Domain] -> [Table] -> [Migration m] + :: (MonadDB m, MonadLog m, MonadMask m) + => ExtrasOptions + -> [Extension] + -> [CompositeType] + -> [Domain] + -> [Table] + -> [Migration m] -> m () migrateDatabase options@ExtrasOptions{..} - extensions domains tables migrations = do + extensions composites domains tables migrations = do setDBTimeZoneToUTC mapM_ checkExtension extensions tablesWithVersions <- getTableVersions (tableVersions : tables) -- 'checkDBConsistency' also performs migrations. checkDBConsistency options domains tablesWithVersions migrations + resultCheck =<< checkCompositesStructure True composites resultCheck =<< checkDomainsStructure domains resultCheck =<< checkDBStructure options tablesWithVersions resultCheck =<< checkTablesWereDropped migrations @@ -69,22 +78,23 @@ -- needs to be migrated. Will do a full check of DB structure. checkDatabase :: forall m . (MonadDB m, MonadLog m, MonadThrow m) - => ExtrasOptions -> [Domain] -> [Table] -> m () + => ExtrasOptions -> [CompositeType] -> [Domain] -> [Table] -> m () checkDatabase options = checkDatabase_ options False -- | Same as 'checkDatabase', but will not failed if there are -- additional tables in database. checkDatabaseAllowUnknownTables :: forall m . (MonadDB m, MonadLog m, MonadThrow m) - => ExtrasOptions -> [Domain] -> [Table] -> m () + => ExtrasOptions -> [CompositeType] -> [Domain] -> [Table] -> m () checkDatabaseAllowUnknownTables options = checkDatabase_ options True checkDatabase_ :: forall m . (MonadDB m, MonadLog m, MonadThrow m) - => ExtrasOptions -> Bool -> [Domain] -> [Table] -> m () -checkDatabase_ options allowUnknownTables domains tables = do + => ExtrasOptions -> Bool -> [CompositeType] -> [Domain] -> [Table] -> m () +checkDatabase_ options allowUnknownTables composites domains tables = do tablesWithVersions <- getTableVersions (tableVersions : tables) resultCheck $ checkVersions tablesWithVersions + resultCheck =<< checkCompositesStructure False composites resultCheck =<< checkDomainsStructure domains resultCheck =<< checkDBStructure options tablesWithVersions when (not $ allowUnknownTables) $ do @@ -297,6 +307,64 @@ <> "' that must have been dropped" <> " is still present in the database." +-- | Check that there is 1 to 1 correspondence between composite types in the +-- database and the list of their code definitions. +checkCompositesStructure + :: MonadDB m + => Bool -- ^ Create types if none are present in the database + -> [CompositeType] + -> m ValidationResult +checkCompositesStructure createTypes compositeList = getDBCompositeTypes >>= \case + [] | createTypes -> do -- if there are no composite types in the database, + -- create them (if there are any as code definitions). + mapM_ (runQuery_ . sqlCreateComposite) compositeList + return mempty + dbCompositeTypes -> pure $ mconcat + [ checkNotPresentComposites + , checkDatabaseComposites + ] + where + compositeMap = M.fromList $ + map ((unRawSQL . ctName) &&& ctColumns) compositeList + + checkNotPresentComposites = + let notPresent = S.toList $ M.keysSet compositeMap + S.\\ S.fromList (map (unRawSQL . ctName) dbCompositeTypes) + in validateIsNull "Composite types not present in the database:" notPresent + + checkDatabaseComposites = mconcat . (`map` dbCompositeTypes) $ \dbComposite -> + let cname = unRawSQL $ ctName dbComposite + in case cname `M.lookup` compositeMap of + Just columns -> topMessage "composite type" cname $ + checkColumns 1 columns (ctColumns dbComposite) + Nothing -> validationError $ "Composite type '" <> T.pack (show dbComposite) + <> "' from the database doesn't have a corresponding code definition" + where + checkColumns + :: Int -> [CompositeColumn] -> [CompositeColumn] -> ValidationResult + checkColumns _ [] [] = mempty + checkColumns _ rest [] = validationError $ + objectHasLess "Composite type" "columns" rest + checkColumns _ [] rest = validationError $ + objectHasMore "Composite type" "columns" rest + checkColumns !n (d:defs) (c:cols) = mconcat [ + validateNames $ ccName d == ccName c + , validateTypes $ ccType d == ccType c + , checkColumns (n+1) defs cols + ] + where + validateNames True = mempty + validateNames False = validationError $ + errorMsg ("no. " <> showt n) "names" (unRawSQL . ccName) + + validateTypes True = mempty + validateTypes False = validationError $ + errorMsg (unRawSQL $ ccName d) "types" (T.pack . show . ccType) + + errorMsg ident attr f = + "Column '" <> ident <> "' differs in" + <+> attr <+> "(database:" <+> f c <> ", definition:" <+> f d <> ")." + -- | Checks whether the database is consistent. checkDBStructure :: forall m. (MonadDB m, MonadThrow m) @@ -360,8 +428,10 @@ checkColumns :: Int -> [TableColumn] -> [TableColumn] -> ValidationResult checkColumns _ [] [] = mempty - checkColumns _ rest [] = validationError $ tableHasLess "columns" rest - checkColumns _ [] rest = validationError $ tableHasMore "columns" rest + checkColumns _ rest [] = validationError $ + objectHasLess "Table" "columns" rest + checkColumns _ [] rest = validationError $ + objectHasMore "Table" "columns" rest checkColumns !n (d:defs) (c:cols) = mconcat [ validateNames $ colName d == colName c -- bigserial == bigint + autoincrement and there is no @@ -459,10 +529,13 @@ -- * all 'mgrFrom' are less than table version number of the table in -- the 'tables' list checkDBConsistency - :: forall m. (MonadDB m, MonadLog m, MonadThrow m) + :: forall m. (MonadDB m, MonadLog m, MonadMask m) => ExtrasOptions -> [Domain] -> [(Table, Int32)] -> [Migration m] -> m () checkDBConsistency options domains tablesWithVersions migrations = do + autoTransaction <- tsAutoTransaction <$> getTransactionSettings + unless autoTransaction $ do + error "checkDBConsistency: tsAutoTransaction setting needs to be True" -- Check the validity of the migrations list. validateMigrations validateDropTableMigrations @@ -682,18 +755,41 @@ runMigration Migration{..} = do case mgrAction of StandardMigration mgrDo -> do - logInfo_ $ arrListTable mgrTableName <> showt mgrFrom <+> "->" - <+> showt (succ mgrFrom) + logMigration mgrDo - runQuery_ $ sqlUpdate "table_versions" $ do - sqlSet "version" (succ mgrFrom) - sqlWhereEq "name" (T.unpack . unRawSQL $ mgrTableName) + updateTableVersion DropTableMigration mgrDropTableMode -> do logInfo_ $ arrListTable mgrTableName <> "drop table" runQuery_ $ sqlDropTable mgrTableName mgrDropTableMode runQuery_ $ sqlDelete "table_versions" $ do + sqlWhereEq "name" (T.unpack . unRawSQL $ mgrTableName) + + CreateIndexConcurrentlyMigration tname idx -> do + 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). + runQuery_ $ "DROP INDEX IF EXISTS" <+> indexName tname 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. + runSQL_ "COMMIT" + runQuery_ (sqlCreateIndexConcurrently tname idx) `finally` begin + updateTableVersion + where + logMigration = do + logInfo_ $ arrListTable mgrTableName + <> showt mgrFrom <+> "->" <+> showt (succ mgrFrom) + + updateTableVersion = do + runQuery_ $ sqlUpdate "table_versions" $ do + sqlSet "version" (succ mgrFrom) sqlWhereEq "name" (T.unpack . unRawSQL $ mgrTableName) runMigrations :: [(Text, Int32)] -> m () diff --git a/src/Database/PostgreSQL/PQTypes/Checks/Util.hs b/src/Database/PostgreSQL/PQTypes/Checks/Util.hs --- a/src/Database/PostgreSQL/PQTypes/Checks/Util.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks/Util.hs @@ -12,8 +12,8 @@ checkEquality, checkNames, checkPKPresence, - tableHasLess, - tableHasMore, + objectHasLess, + objectHasMore, arrListTable ) where @@ -152,15 +152,14 @@ , " has no primary key defined " , " (" <> (mintercalate ", " msgs) <> ")"] - -tableHasLess :: Show t => Text -> t -> Text -tableHasLess ptype missing = - "Table in the database has *less*" <+> ptype <+> +objectHasLess :: Show t => Text -> Text -> t -> Text +objectHasLess otype ptype missing = + otype <+> "in the database has *less*" <+> ptype <+> "than its definition (missing:" <+> T.pack (show missing) <> ")" -tableHasMore :: Show t => Text -> t -> Text -tableHasMore ptype extra = - "Table in the database has *more*" <+> ptype <+> +objectHasMore :: Show t => Text -> Text -> t -> Text +objectHasMore otype ptype extra = + otype <+> "in the database has *more*" <+> ptype <+> "than its definition (extra:" <+> T.pack (show extra) <> ")" arrListTable :: RawSQL () -> Text diff --git a/src/Database/PostgreSQL/PQTypes/Model/Check.hs b/src/Database/PostgreSQL/PQTypes/Model/Check.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Check.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Check.hs @@ -15,8 +15,8 @@ data Check = Check { chkName :: RawSQL () , chkCondition :: RawSQL () -, chkValidated :: Bool -- ^ Set to 'True' if check is created as NOT VALID and - -- not validated afterwards. +, chkValidated :: Bool -- ^ Set to 'False' if check is created as NOT VALID and + -- left in such state (for whatever reason). } deriving (Eq, Ord, Show) tblCheck :: Check diff --git a/src/Database/PostgreSQL/PQTypes/Model/CompositeType.hs b/src/Database/PostgreSQL/PQTypes/Model/CompositeType.hs --- a/src/Database/PostgreSQL/PQTypes/Model/CompositeType.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/CompositeType.hs @@ -1,14 +1,20 @@ module Database.PostgreSQL.PQTypes.Model.CompositeType ( CompositeType(..) , CompositeColumn(..) - , defineComposites + , compositeTypePqFormat + , sqlCreateComposite + , sqlDropComposite + , getDBCompositeTypes ) where +import Data.Int import Data.Monoid.Utils import Database.PostgreSQL.PQTypes -import Prelude +import qualified Data.ByteString as BS +import qualified Data.Text.Encoding as T import Database.PostgreSQL.PQTypes.Model.ColumnType +import Database.PostgreSQL.PQTypes.SQL.Builder data CompositeType = CompositeType { ctName :: !(RawSQL ()) @@ -20,24 +26,50 @@ , ccType :: ColumnType } deriving (Eq, Ord, Show) --- | Composite types are static in a sense that they can either --- be created or dropped, altering them is not possible. Therefore --- they are not part of the migration process. This is not a problem --- since their exclusive usage is for intermediate representation --- of complex nested data structures fetched from the database. -defineComposites :: MonadDB m => [CompositeType] -> m () -defineComposites ctypes = do - mapM_ (runQuery_ . sqlDropComposite) $ reverse ctypes - mapM_ (runQuery_ . sqlCreateComposite) $ ctypes +-- | Convenience function for converting CompositeType definition to +-- corresponding 'pqFormat' definition. +compositeTypePqFormat :: CompositeType -> BS.ByteString +compositeTypePqFormat ct = "%" `BS.append` T.encodeUtf8 (unRawSQL $ ctName ct) + +-- | Make SQL query that creates a composite type. +sqlCreateComposite :: CompositeType -> RawSQL () +sqlCreateComposite CompositeType{..} = smconcat [ + "CREATE TYPE" + , ctName + , "AS (" + , mintercalate ", " $ map columnToSQL ctColumns + , ")" + ] where - sqlCreateComposite CompositeType{..} = smconcat [ - "CREATE TYPE" - , ctName - , "AS (" - , mintercalate ", " $ map columnToSQL ctColumns - , ")" - ] - where - columnToSQL CompositeColumn{..} = ccName <+> columnTypeToSQL ccType + columnToSQL CompositeColumn{..} = ccName <+> columnTypeToSQL ccType - sqlDropComposite = ("DROP TYPE IF EXISTS" <+>) . ctName +-- | Make SQL query that drops a composite type. +sqlDropComposite :: RawSQL () -> RawSQL () +sqlDropComposite = ("DROP TYPE" <+>) + +---------------------------------------- + +-- | Get composite types defined in the database. +getDBCompositeTypes :: forall m. MonadDB m => m [CompositeType] +getDBCompositeTypes = do + runQuery_ . sqlSelect "pg_catalog.pg_class c" $ do + sqlResult "c.relname::text" + sqlResult "c.oid::int4" + sqlWhere "pg_catalog.pg_table_is_visible(c.oid)" + sqlWhereEq "c.relkind" 'c' + sqlOrderBy "c.relname" + mapM getComposite =<< fetchMany id + where + getComposite :: (String, Int32) -> m CompositeType + getComposite (name, oid) = do + runQuery_ . sqlSelect "pg_catalog.pg_attribute a" $ do + sqlResult "a.attname::text" + sqlResult "pg_catalog.format_type(a.atttypid, a.atttypmod)" + sqlWhereEq "a.attrelid" oid + sqlOrderBy "a.attnum" + columns <- fetchMany fetch + return CompositeType { ctName = unsafeSQL name, ctColumns = columns } + where + fetch :: (String, ColumnType) -> CompositeColumn + fetch (cname, ctype) = + CompositeColumn { ccName = unsafeSQL cname, ccType = ctype } diff --git a/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs b/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs --- a/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs @@ -25,8 +25,8 @@ , fkOnDelete :: ForeignKeyAction , fkDeferrable :: Bool , fkDeferred :: Bool -, fkValidated :: Bool -- ^ Set to 'True' if foreign key is created as NOT VALID - -- and not validated afterwards. +, fkValidated :: Bool -- ^ Set to 'False' if foreign key is created as NOT + -- VALID and left in such state (for whatever reason). } deriving (Eq, Ord, Show) data ForeignKeyAction diff --git a/src/Database/PostgreSQL/PQTypes/Model/Index.hs b/src/Database/PostgreSQL/PQTypes/Model/Index.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Index.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Index.hs @@ -150,12 +150,13 @@ sqlCreateIndex_ :: Bool -> RawSQL () -> TableIndex -> RawSQL () sqlCreateIndex_ concurrently tname idx@TableIndex{..} = mconcat [ - "CREATE " - , if idxUnique then "UNIQUE " else "" - , "INDEX " <+> indexName tname idx - , if concurrently then " CONCURRENTLY" else "" - , " ON" <+> tname <+> "" - , "USING" <+> (rawSQL (T.pack . show $ idxMethod) ()) <+> "(" + "CREATE" + , if idxUnique then " UNIQUE" else "" + , " INDEX " + , if concurrently then "CONCURRENTLY " else "" + , indexName tname idx + , " ON" <+> tname + , " USING" <+> (rawSQL (T.pack . show $ idxMethod) ()) <+> "(" , mintercalate ", " idxColumns , ")" , maybe "" (" WHERE" <+>) idxWhere diff --git a/src/Database/PostgreSQL/PQTypes/Model/Migration.hs b/src/Database/PostgreSQL/PQTypes/Model/Migration.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Migration.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Migration.hs @@ -30,6 +30,7 @@ import Data.Int +import Database.PostgreSQL.PQTypes.Model.Index import Database.PostgreSQL.PQTypes.Model.Table import Database.PostgreSQL.PQTypes.SQL.Raw @@ -45,6 +46,11 @@ -- the table to drop. | DropTableMigration DropTableMode + -- | Migration for creating an index concurrently. + | CreateIndexConcurrentlyMigration + (RawSQL ()) -- ^ Table name + TableIndex -- ^ Index + -- | Migration object. data Migration m = Migration { @@ -62,11 +68,13 @@ isStandardMigration :: Migration m -> Bool isStandardMigration Migration{..} = case mgrAction of - StandardMigration _ -> True - DropTableMigration _ -> False + StandardMigration{} -> True + DropTableMigration{} -> False + CreateIndexConcurrentlyMigration{} -> False isDropTableMigration :: Migration m -> Bool isDropTableMigration Migration{..} = case mgrAction of - StandardMigration _ -> False - DropTableMigration _ -> True + StandardMigration{} -> False + DropTableMigration{} -> True + CreateIndexConcurrentlyMigration{} -> False diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -15,6 +15,7 @@ import Database.PostgreSQL.PQTypes.Checks import Database.PostgreSQL.PQTypes.Model.ColumnType import Database.PostgreSQL.PQTypes.Model.ForeignKey +import Database.PostgreSQL.PQTypes.Model.Index import Database.PostgreSQL.PQTypes.Model.Migration import Database.PostgreSQL.PQTypes.Model.PrimaryKey import Database.PostgreSQL.PQTypes.Model.Table @@ -105,8 +106,8 @@ } -tableBankMigration5 :: (MonadDB m) => Migration m -tableBankMigration5 = Migration +tableBankMigration5fst :: (MonadDB m) => Migration m +tableBankMigration5fst = Migration { mgrTableName = tblName tableBankSchema3 , mgrFrom = 2 , mgrAction = StandardMigration $ do @@ -115,12 +116,21 @@ ] } +tableBankMigration5snd :: (MonadDB m) => Migration m +tableBankMigration5snd = Migration + { mgrTableName = tblName tableBankSchema3 + , mgrFrom = 3 + , mgrAction = CreateIndexConcurrentlyMigration + (tblName tableBankSchema3) + (indexOnColumn "name") + } tableBankSchema5 :: Table tableBankSchema5 = tableBankSchema4 { - tblVersion = (tblVersion tableBankSchema4) + 1 + tblVersion = (tblVersion tableBankSchema4) + 2 , tblColumns = filter (\c -> colName c /= "cash") (tblColumns tableBankSchema4) + , tblIndexes = [indexOnColumn "name"] } tableBadGuySchema1 :: Table @@ -394,7 +404,8 @@ schema5Migrations :: (MonadDB m) => [Migration m] schema5Migrations = schema4Migrations ++ [ createTableMigration tableFlash - , tableBankMigration5 + , tableBankMigration5fst + , tableBankMigration5snd , dropTableMigration tableFlash ] @@ -428,11 +439,12 @@ createTablesSchema1 step = do let extrasOptions = def extensions = [] + composites = [] domains = [] step "Creating the database (schema version 1)..." migrateDatabase extrasOptions extensions domains - schema1Tables schema1Migrations - checkDatabase extrasOptions domains schema1Tables + composites schema1Tables schema1Migrations + checkDatabase extrasOptions composites domains schema1Tables testDBSchema1 :: (String -> TestM ()) -> TestM ([Int64], [Int64]) testDBSchema1 step = do @@ -518,23 +530,25 @@ migrateDBToSchema2 step = do let extrasOptions = def extensions = [] + composites = [] domains = [] step "Migrating the database (schema version 1 -> schema version 2)..." - migrateDatabase extrasOptions extensions domains + migrateDatabase extrasOptions extensions composites domains schema2Tables schema2Migrations - checkDatabase extrasOptions domains schema2Tables + checkDatabase extrasOptions composites domains schema2Tables -- | Hacky version of 'migrateDBToSchema2' used by 'migrationTest3'. migrateDBToSchema2Hacky :: (String -> TestM ()) -> TestM () migrateDBToSchema2Hacky step = do let extrasOptions = def extensions = [] + composites = [] domains = [] step "Hackily migrating the database (schema version 1 \ \-> schema version 2)..." - migrateDatabase extrasOptions extensions domains + migrateDatabase extrasOptions extensions composites domains schema2Tables schema2Migrations' - checkDatabase extrasOptions domains schema2Tables + checkDatabase extrasOptions composites domains schema2Tables where schema2Migrations' = createTableMigration tableFlash : schema2Migrations @@ -578,11 +592,12 @@ migrateDBToSchema3 step = do let extrasOptions = def extensions = [] + composites = [] domains = [] step "Migrating the database (schema version 2 -> schema version 3)..." - migrateDatabase extrasOptions extensions domains + migrateDatabase extrasOptions extensions composites domains schema3Tables schema3Migrations - checkDatabase extrasOptions domains schema3Tables + checkDatabase extrasOptions composites domains schema3Tables testDBSchema3 :: (String -> TestM ()) -> [Int64] -> [Int64] -> TestM () testDBSchema3 step badGuyIds robberyIds = do @@ -629,11 +644,12 @@ migrateDBToSchema4 step = do let extrasOptions = def extensions = [] + composites = [] domains = [] step "Migrating the database (schema version 3 -> schema version 4)..." - migrateDatabase extrasOptions extensions domains + migrateDatabase extrasOptions extensions composites domains schema4Tables schema4Migrations - checkDatabase extrasOptions domains schema4Tables + checkDatabase extrasOptions composites domains schema4Tables testDBSchema4 :: (String -> TestM ()) -> TestM () testDBSchema4 step = do @@ -654,11 +670,12 @@ migrateDBToSchema5 step = do let extrasOptions = def extensions = [] + composites = [] domains = [] step "Migrating the database (schema version 4 -> schema version 5)..." - migrateDatabase extrasOptions extensions domains + migrateDatabase extrasOptions extensions composites domains schema5Tables schema5Migrations - checkDatabase extrasOptions domains schema5Tables + checkDatabase extrasOptions composites domains schema5Tables testDBSchema5 :: (String -> TestM ()) -> TestM () testDBSchema5 step = do @@ -729,38 +746,38 @@ differentSchema = schema5Tables extrasOptions = def { eoEnforcePKs = True } assertNoException "checkDatabase should run fine for consistent DB" $ - checkDatabase extrasOptions [] currentSchema + checkDatabase extrasOptions [] [] currentSchema assertNoException "checkDatabaseAllowUnknownTables runs fine \ \for consistent DB" $ - checkDatabaseAllowUnknownTables extrasOptions [] currentSchema + checkDatabaseAllowUnknownTables extrasOptions [] [] currentSchema assertException "checkDatabase should throw exception for wrong schema" $ - checkDatabase extrasOptions [] differentSchema + checkDatabase extrasOptions [] [] differentSchema assertException ("checkDatabaseAllowUnknownTables \ \should throw exception for wrong scheme") $ - checkDatabaseAllowUnknownTables extrasOptions [] differentSchema + checkDatabaseAllowUnknownTables extrasOptions [] [] differentSchema runSQL_ "INSERT INTO table_versions (name, version) \ \VALUES ('unknown_table', 0)" assertException "checkDatabase throw when extra entry in 'table_versions'" $ - checkDatabase extrasOptions [] currentSchema + checkDatabase extrasOptions [] [] currentSchema assertNoException ("checkDatabaseAllowUnknownTables \ \accepts extra entry in 'table_versions'") $ - checkDatabaseAllowUnknownTables extrasOptions [] currentSchema + checkDatabaseAllowUnknownTables extrasOptions [] [] currentSchema runSQL_ "DELETE FROM table_versions where name='unknown_table'" runSQL_ "CREATE TABLE unknown_table (title text)" assertException "checkDatabase should throw with unknown table" $ - checkDatabase extrasOptions [] currentSchema + checkDatabase extrasOptions [] [] currentSchema assertNoException "checkDatabaseAllowUnknownTables accepts unknown table" $ - checkDatabaseAllowUnknownTables extrasOptions [] currentSchema + checkDatabaseAllowUnknownTables extrasOptions [] [] currentSchema runSQL_ "INSERT INTO table_versions (name, version) \ \VALUES ('unknown_table', 0)" assertException "checkDatabase should throw with unknown table" $ - checkDatabase extrasOptions [] currentSchema + checkDatabase extrasOptions [] [] currentSchema assertNoException ("checkDatabaseAllowUnknownTables \ \accepts unknown tables with version") $ - checkDatabaseAllowUnknownTables extrasOptions [] currentSchema + checkDatabaseAllowUnknownTables extrasOptions [] [] currentSchema freshTestDB step @@ -772,18 +789,18 @@ step "Recreating the database (schema version 1, one table is missing PK)..." - migrateDatabase optionsNoPKCheck [] [] + migrateDatabase optionsNoPKCheck [] [] [] schema1TablesWithMissingPK [schema1MigrationsWithMissingPK] - checkDatabase optionsNoPKCheck [] withMissingPKSchema + checkDatabase optionsNoPKCheck [] [] withMissingPKSchema assertException "checkDatabase should throw when PK missing from table \ \'participated_in_robbery' and check is enabled" $ - checkDatabase optionsWithPKCheck [] withMissingPKSchema + checkDatabase optionsWithPKCheck [] [] withMissingPKSchema assertNoException "checkDatabase should not throw when PK missing from table \ \'participated_in_robbery' and check is disabled" $ - checkDatabase optionsNoPKCheck [] withMissingPKSchema + checkDatabase optionsNoPKCheck [] [] withMissingPKSchema freshTestDB step