hpqtypes-extras 1.6.4.0 → 1.7.0.0
raw patch · 11 files changed
+374/−258 lines, 11 files
Files
- CHANGELOG.md +19/−3
- hpqtypes-extras.cabal +1/−1
- src/Database/PostgreSQL/PQTypes/Checks.hs +140/−156
- src/Database/PostgreSQL/PQTypes/Checks/Util.hs +54/−22
- src/Database/PostgreSQL/PQTypes/Migrate.hs +4/−4
- src/Database/PostgreSQL/PQTypes/Model/Check.hs +39/−3
- src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs +31/−1
- src/Database/PostgreSQL/PQTypes/Model/Index.hs +30/−2
- src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs +14/−0
- src/Database/PostgreSQL/PQTypes/Model/Table.hs +14/−8
- test/Main.hs +28/−58
CHANGELOG.md view
@@ -1,6 +1,22 @@-# hpqtypes-extras-1.6.4.0 (2019-02-04)-* Fix an issue where unnecessary migrations were run sometimes- ([#19](https://github.com/scrive/hpqtypes-extras/pull/19)).+# hpqtypes-extras-1.7.0.0 (2019-01-08)+* Added support for no-downtime migrations+ ([#17](https://github.com/scrive/hpqtypes-extras/pull/17)):+ - `sqlCreateIndex` is deprecated. Use either+ `sqlCreateIndexSequentially` or `sqlCreateIndexConcurrently`+ (no-downtime migration variant) instead.+ - `sqlAddFK` is deprecated. Use either `sqlAddValidFK` or+ `sqlAddNotValidFK` (no-downtime migration variant) instead.+ - API addition: `sqlValidateFK`, for validating a foreign key+ previously added with `sqlAddNotValidFK`.+ - `sqlAddCheck` is deprecated. Use either `sqlAddValidCheck` or+ `sqlAddNotValidCheck` (no-downtime migration variant) instead.+ - API addition: `sqlValidateCheck`, for validating a check+ previously added with `sqlAddNotValidCheck`.+ - API addition: `sqlAddPKUsing`, converts a unique index to a+ primary key.+ - New `Table` field: `tblAcceptedDbVersions`.+* `ValidationResult` is now an abstract type.+* `ValidationResult` now supports info-level messages in addition to errors. # hpqtypes-extras-1.6.3.0 (2018-11-19) * API addition: `sqlWhereAnyE`
hpqtypes-extras.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: hpqtypes-extras-version: 1.6.4.0+version: 1.7.0.0 synopsis: Extra utilities for hpqtypes library description: The following extras for hpqtypes library: .
src/Database/PostgreSQL/PQTypes/Checks.hs view
@@ -24,7 +24,6 @@ import qualified Data.String import Data.Text (Text) import Database.PostgreSQL.PQTypes hiding (def)-import GHC.Stack (HasCallStack) import Log import Prelude import TextShow@@ -49,14 +48,14 @@ :: (MonadDB m, MonadLog m, MonadThrow m) => ExtrasOptions -> [Extension] -> [Domain] -> [Table] -> [Migration m] -> m ()-migrateDatabase options@ExtrasOptions{..}- extensions domains tables migrations = do+migrateDatabase options@ExtrasOptions{..} extensions domains tables migrations = do setDBTimeZoneToUTC mapM_ checkExtension extensions+ tablesWithVersions <- getTableVersions (tableVersions : tables) -- 'checkDBConsistency' also performs migrations.- checkDBConsistency options domains (tableVersions : tables) migrations+ checkDBConsistency options domains tablesWithVersions migrations resultCheck =<< checkDomainsStructure domains- resultCheck =<< checkDBStructure options (tableVersions : tables)+ resultCheck =<< checkDBStructure options tablesWithVersions resultCheck =<< checkTablesWereDropped migrations resultCheck =<< checkUnknownTables tables resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables)@@ -82,11 +81,10 @@ :: forall m . (MonadDB m, MonadLog m, MonadThrow m) => ExtrasOptions -> Bool -> [Domain] -> [Table] -> m () checkDatabase_ options allowUnknownTables domains tables = do- tablesWithVersions <- getTableVersions tables-+ tablesWithVersions <- getTableVersions (tableVersions : tables) resultCheck $ checkVersions tablesWithVersions resultCheck =<< checkDomainsStructure domains- resultCheck =<< checkDBStructure options (tableVersions : tables)+ resultCheck =<< checkDBStructure options tablesWithVersions when (not $ allowUnknownTables) $ do resultCheck =<< checkUnknownTables tables resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables)@@ -97,27 +95,34 @@ where checkVersions :: [(Table, Int32)] -> ValidationResult- checkVersions vs = mconcat . map (ValidationResult . checkVersion) $ vs+ checkVersions vs = mconcat . map checkVersion $ vs - checkVersion :: (Table, Int32) -> [Text]+ checkVersion :: (Table, Int32) -> ValidationResult checkVersion (t@Table{..}, v)- | tblVersion == v = []- | v == 0 = ["Table '" <> tblNameText t <> "' must be created"]- | otherwise = ["Table '" <> tblNameText t- <> "' must be migrated" <+> showt v <+> "->"- <+> showt tblVersion]+ | tblVersion `elem` tblAcceptedDbVersions+ = validationError $+ "Table '" <> tblNameText t <>+ "' has its current table version in accepted db versions"+ | tblVersion == v || v `elem` tblAcceptedDbVersions+ = mempty+ | v == 0 = validationError $+ "Table '" <> tblNameText t <> "' must be created"+ | otherwise = validationError $+ "Table '" <> tblNameText t+ <> "' must be migrated" <+> showt v <+> "->"+ <+> showt tblVersion checkInitialSetups :: [Table] -> m ValidationResult checkInitialSetups tbls =- liftM mconcat . mapM (liftM ValidationResult . checkInitialSetup') $ tbls+ liftM mconcat . mapM checkInitialSetup' $ tbls - checkInitialSetup' :: Table -> m [Text]+ checkInitialSetup' :: Table -> m ValidationResult checkInitialSetup' t@Table{..} = case tblInitialSetup of- Nothing -> return []+ Nothing -> return mempty Just is -> checkInitialSetup is >>= \case- True -> return []- False -> return ["Initial setup for table '"- <> tblNameText t <> "' is not valid"]+ True -> return mempty+ False -> return . validationError $ "Initial setup for table '"+ <> tblNameText t <> "' is not valid" -- | Return SQL fragment of current catalog within quotes currentCatalog :: (MonadDB m, MonadThrow m) => m (RawSQL ())@@ -182,18 +187,20 @@ then do mapM_ (logInfo_ . (<+>) "Unknown table:") absent mapM_ (logInfo_ . (<+>) "Table not present in the database:") notPresent- return . ValidationResult $- (joinedResult "Unknown tables:" absent) ++- (joinedResult "Tables not present in the database:" notPresent)+ return $+ (validateIsNull "Unknown tables:" absent) <>+ (validateIsNull "Tables not present in the database:" notPresent) else return mempty- where- joinedResult :: Text -> [Text] -> [Text]- joinedResult _ [] = []- joinedResult t ts = [ t <+> T.intercalate ", " ts] +validateIsNull :: Text -> [Text] -> ValidationResult+validateIsNull _ [] = mempty+validateIsNull msg ts = validationError $ msg <+> T.intercalate ", " 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+ :: (MonadDB m, MonadLog m)+ => [Table] -> m ValidationResult checkExistenceOfVersionsForTables tables = do runQuery_ $ sqlSelect "table_versions" $ do sqlResult "name::text"@@ -206,16 +213,11 @@ if (not . null $ absent) || (not . null $ notPresent) then do mapM_ (logInfo_ . (<+>) "Unknown entry in 'table_versions':") absent- mapM_ (logInfo_ . (<+>) "Table not present in the 'table_versions':")- notPresent- return . ValidationResult $- (joinedResult "Unknown entry in table_versions':" absent ) ++- (joinedResult "Tables not present in the 'table_versions':" notPresent)+ mapM_ (logInfo_ . (<+>) "Table not present in the 'table_versions':") notPresent+ return $+ (validateIsNull "Unknown entry in table_versions':" absent ) <>+ (validateIsNull "Tables not present in the 'table_versions':" notPresent) else return mempty- where- joinedResult :: Text -> [Text] -> [Text]- joinedResult _ [] = []- joinedResult t ts = [ t <+> T.intercalate ", " ts] checkDomainsStructure :: (MonadDB m, MonadThrow m)@@ -228,17 +230,19 @@ sqlResult "t1.typdefault" -- default value sqlResult "ARRAY(SELECT c.conname::text FROM pg_catalog.pg_constraint c WHERE c.contypid = t1.oid ORDER by c.oid)" -- constraint names sqlResult "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+ sqlResult "ARRAY(SELECT c.convalidated FROM pg_catalog.pg_constraint c WHERE c.contypid = t1.oid ORDER by c.oid)" -- are constraints validated? sqlWhereEq "t1.typname" $ unRawSQL $ domName def- mdom <- fetchMaybe $ \(dname, dtype, nullable, defval, cnames, conds) ->+ mdom <- fetchMaybe $ \(dname, dtype, nullable, defval, cnames, conds, valids) -> Domain { domName = unsafeSQL dname , domType = dtype , domNullable = nullable , domDefault = unsafeSQL <$> defval- , domChecks = mkChecks $ zipWith (\cname cond -> Check {+ , domChecks = mkChecks $ zipWith3 (\cname cond validated -> Check { chkName = unsafeSQL cname , chkCondition = unsafeSQL cond- }) (unArray1 cnames) (unArray1 conds)+ , chkValidated = validated+ }) (unArray1 cnames) (unArray1 conds) (unArray1 valids) } return $ case mdom of Just dom@@ -250,17 +254,17 @@ , compareAttr dom def "checks" domChecks ] | otherwise -> mempty- Nothing -> ValidationResult ["Domain '" <> unRawSQL (domName def)- <> "' doesn't exist in the database"]+ Nothing -> validationError $ "Domain '" <> unRawSQL (domName def)+ <> "' doesn't exist in the database" where compareAttr :: (Eq a, Show a) => Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult compareAttr dom def attrname attr- | attr dom == attr def = ValidationResult []- | otherwise = ValidationResult- [ "Attribute '" <> attrname- <> "' does not match (database:" <+> T.pack (show $ attr dom)- <> ", definition:" <+> T.pack (show $ attr def) <> ")" ]+ | attr dom == attr def = mempty+ | otherwise = validationError $+ "Attribute '" <> attrname+ <> "' does not match (database:" <+> T.pack (show $ attr dom)+ <> ", definition:" <+> T.pack (show $ attr def) <> ")" -- | Check that the tables that must have been dropped are actually -- missing from the DB.@@ -274,17 +278,24 @@ mver <- checkTableVersion (T.unpack . unRawSQL $ tblName) return $ if isNothing mver then mempty- else ValidationResult [ "The table '" <> unRawSQL tblName- <> "' that must have been dropped"- <> " is still present in the database." ]+ else validationError $ "The table '" <> unRawSQL tblName+ <> "' that must have been dropped"+ <> " is still present in the database." --- | Checks whether database is consistent.-checkDBStructure :: forall m. (MonadDB m, MonadThrow m)- => ExtrasOptions -> [Table] -> m ValidationResult-checkDBStructure options tables = fmap mconcat . forM tables $ \table ->- -- final checks for table structure, we do this- -- both when creating stuff and when migrating- topMessage "table" (tblNameText table) <$> checkTableStructure table+-- | Checks whether the database is consistent.+checkDBStructure+ :: forall m. (MonadDB m, MonadThrow m)+ => ExtrasOptions+ -> [(Table, Int32)]+ -> m ValidationResult+checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) ->+ do+ result <- topMessage "table" (tblNameText table) <$> checkTableStructure 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.+ return $ if version `elem` tblAcceptedDbVersions table+ then validationErrorsToInfos result+ else result where checkTableStructure :: Table -> m ValidationResult checkTableStructure table@Table{..} = do@@ -321,8 +332,7 @@ , checkForeignKeys tblForeignKeys fkeys ] where- fetchTableColumn- :: (String, ColumnType, Bool, Maybe String) -> TableColumn+ fetchTableColumn :: (String, ColumnType, Bool, Maybe String) -> TableColumn fetchTableColumn (name, ctype, nullable, mdefault) = TableColumn { colName = unsafeSQL name , colType = ctype@@ -330,20 +340,18 @@ , colDefault = unsafeSQL `liftM` mdefault } - checkColumns- :: Int -> [TableColumn] -> [TableColumn] -> ValidationResult+ checkColumns :: Int -> [TableColumn] -> [TableColumn] -> ValidationResult checkColumns _ [] [] = mempty- checkColumns _ rest [] = ValidationResult [tableHasLess "columns" rest]- checkColumns _ [] rest = ValidationResult [tableHasMore "columns" rest]+ checkColumns _ rest [] = validationError $ tableHasLess "columns" rest+ checkColumns _ [] rest = validationError $ tableHasMore "columns" rest checkColumns !n (d:defs) (c:cols) = mconcat [ validateNames $ colName d == colName c -- bigserial == bigint + autoincrement and there is no -- distinction between them after table is created. , validateTypes $ colType d == colType c || (colType d == BigSerialT && colType c == 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.+ -- there is a problem with default values determined by sequences as+ -- they're implicitely specified by db, so let's omit them in such case , validateDefaults $ colDefault d == colDefault c || (colDefault d == Nothing && ((T.isPrefixOf "nextval('" . unRawSQL) `liftM` colDefault c)@@ -352,25 +360,25 @@ , checkColumns (n+1) defs cols ] where- validateNames True = mempty- validateNames False = ValidationResult- [ errorMsg ("no. " <> showt n) "names" (unRawSQL . colName) ]+ validateNames True = mempty+ validateNames False = validationError $+ errorMsg ("no. " <> showt n) "names" (unRawSQL . colName) - validateTypes True = mempty- validateTypes False = ValidationResult- [ errorMsg cname "types" (T.pack . show . colType)- <+> sqlHint ("TYPE" <+> columnTypeToSQL (colType d)) ]+ validateTypes True = mempty+ validateTypes False = validationError $+ errorMsg cname "types" (T.pack . show . colType)+ <+> sqlHint ("TYPE" <+> columnTypeToSQL (colType d)) - validateNullables True = mempty- validateNullables False = ValidationResult- [ errorMsg cname "nullables" (showt . colNullable)- <+> sqlHint ((if colNullable d then "DROP" else "SET")- <+> "NOT NULL") ]+ validateNullables True = mempty+ validateNullables False = validationError $+ errorMsg cname "nullables" (showt . colNullable)+ <+> sqlHint ((if colNullable d then "DROP" else "SET")+ <+> "NOT NULL") - validateDefaults True = mempty- validateDefaults False = ValidationResult- [ (errorMsg cname "defaults" (showt . fmap unRawSQL . colDefault))- <+> sqlHint set_default ]+ validateDefaults True = mempty+ validateDefaults False = validationError $+ (errorMsg cname "defaults" (showt . fmap unRawSQL . colDefault))+ <+> sqlHint set_default where set_default = case colDefault d of Just v -> "SET DEFAULT" <+> v@@ -399,10 +407,15 @@ pk = maybeToList mpk checkChecks :: [Check] -> [Check] -> ValidationResult- checkChecks defs checks = case checkEquality "CHECKs" defs checks of- ValidationResult [] -> ValidationResult []- ValidationResult errmsgs -> ValidationResult $- errmsgs ++ [" (HINT: If checks are equal modulo number of parentheses/whitespaces used in conditions, just copy and paste expected output into source code)"]+ checkChecks defs checks =+ mapValidationResult id mapErrs (checkEquality "CHECKs" defs checks)+ where+ mapErrs [] = []+ mapErrs errmsgs = errmsgs <>+ [ " (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@@ -428,15 +441,14 @@ -- the 'tables' list checkDBConsistency :: forall m. (MonadDB m, MonadLog m, MonadThrow m)- => ExtrasOptions -> [Domain] -> [Table] -> [Migration m]+ => ExtrasOptions -> [Domain] -> [(Table, Int32)] -> [Migration m] -> m ()-checkDBConsistency options domains tables migrations = do+checkDBConsistency options domains tablesWithVersions migrations = do -- Check the validity of the migrations list. validateMigrations validateDropTableMigrations -- Load version numbers of the tables that actually exist in the DB.- tablesWithVersions <- getTableVersions $ tables dbTablesWithVersions <- getDBTableVersions if all ((==) 0 . snd) tablesWithVersions@@ -456,8 +468,9 @@ runMigrations dbTablesWithVersions where+ tables = map fst tablesWithVersions - errorInvalidMigrations :: HasCallStack => [RawSQL ()] -> a+ errorInvalidMigrations :: [RawSQL ()] -> a errorInvalidMigrations tblNames = error $ "checkDBConsistency: invalid migrations for tables" <+> (L.intercalate ", " $ map (T.unpack . unRawSQL) tblNames)@@ -500,9 +513,8 @@ <> "and dropped tables is not empty") $ object [ "intersection" .= map unRawSQL intersection ]- errorInvalidMigrations [ tblName tbl- | tbl <- tables- , tblName tbl `elem` intersection ]+ errorInvalidMigrations [ tblName tbl | tbl <- tables+ , tblName tbl `elem` 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@@ -523,9 +535,8 @@ logAttention ("Migration lists for some tables contain " <> "either multiple drop table migrations or " <> "a drop table migration in non-tail position.")- $ object [ "tables" .=- [ unRawSQL tblName- | tblName <- tablesWithInvalidMigrationLists ] ]+ $ object [ "tables" .= [ unRawSQL tblName+ | tblName <- tablesWithInvalidMigrationLists ] ] errorInvalidMigrations tablesWithInvalidMigrationLists createDBSchema :: m ()@@ -549,11 +560,10 @@ initialSetup tis logInfo_ "Done." - -- | Input is a list of (table name, expected version, actual- -- version) triples.+ -- | Input is a list of (table name, expected version, actual version) triples. validateMigrationsAgainstDB :: [(RawSQL (), Int32, Int32)] -> m ()- validateMigrationsAgainstDB tablesWithVersions- = forM_ tablesWithVersions $ \(tableName, expectedVer, actualVer) ->+ validateMigrationsAgainstDB tablesWithVersions_+ = forM_ tablesWithVersions_ $ \(tableName, expectedVer, actualVer) -> when (expectedVer /= actualVer) $ case [ m | m@Migration{..} <- migrations , mgrTableName == tableName ] of@@ -580,8 +590,7 @@ forM_ dbTablesToDropWithVersions $ \(tblName, fromVer, ver) -> when (fromVer /= ver) $ -- 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.+ -- version, check that there are migrations that bring it to a new one. validateMigrationsAgainstDB [(tblName, fromVer, ver)] findMigrationsToRun :: [(Text, Int32)] -> [Migration m]@@ -592,8 +601,7 @@ droppedEventually mgr = mgrTableName mgr `elem` tableNamesToDrop lookupVer :: Migration m -> Maybe Int32- lookupVer mgr = lookup (unRawSQL $ mgrTableName mgr)- dbTablesWithVersions+ lookupVer mgr = lookup (unRawSQL $ mgrTableName mgr) dbTablesWithVersions tableDoesNotExist = isNothing . lookupVer @@ -607,8 +615,7 @@ -- table migration and we're not going to drop the -- table afterwards, this is our starting point. Nothing -> not $- (mgrFrom mgr == 0) &&- (not . droppedEventually $ mgr)+ (mgrFrom mgr == 0) && (not . droppedEventually $ mgr) -- Table exists in the DB. Run only those migrations -- that have mgrFrom >= table version in the DB. Just ver -> not $@@ -621,29 +628,13 @@ -- 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 = length migrationsToRun'- initialMigrations = drop l $ reverse migrations- additionalMigrations' = takeWhile+ -- doSomethingTo t1, dropTable t.+ l = length migrationsToRun'+ initialMigrations = drop l $ reverse migrations+ additionalMigrations = takeWhile (\mgr -> droppedEventually mgr && tableDoesNotExist mgr) 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 =- let ret = reverse additionalMigrations'- grps = L.groupBy ((==) `on` mgrTableName) ret- in if any ((/=) 0 . mgrFrom . head) grps- then []- else ret- -- Also there's no point in adding these extra migrations if- -- we're not running any migrations to begin with.- migrationsToRun = if not . null $ migrationsToRun'- then additionalMigrations ++ migrationsToRun'- else []+ migrationsToRun = (reverse additionalMigrations) ++ migrationsToRun' in migrationsToRun runMigration :: (Migration m) -> m ()@@ -674,12 +665,9 @@ runMigration mgr when (eoForceCommit options) $ do- logInfo_ $ "Forcing commit after migraton"- <> " and starting new transaction..."+ logInfo_ $ "Committing migration changes..." commit- begin- logInfo_ $ "Forcing commit after migraton"- <> " and starting new transaction... done."+ logInfo_ $ "Committing migration changes done." logInfo_ "!IMPORTANT! Database has been permanently changed" logInfo_ "Running migrations... done." @@ -824,9 +812,7 @@ -- *** PRIMARY KEY *** -sqlGetPrimaryKey- :: (MonadDB m, MonadThrow m)- => Table -> m (Maybe (PrimaryKey, RawSQL ()))+sqlGetPrimaryKey :: (MonadDB m, MonadThrow m) => Table -> m (Maybe (PrimaryKey, RawSQL ())) sqlGetPrimaryKey table = do (mColumnNumbers :: Maybe [Int16]) <- do@@ -863,8 +849,7 @@ sqlWhereEq "c.contype" 'p' sqlWhereEqSql "c.conrelid" $ sqlGetTableID table sqlResult "c.conname::text"- sqlResult $ Data.String.fromString- ("array['" <> (mintercalate "', '" columnNames) <> "']::text[]")+ sqlResult $ Data.String.fromString ("array['" <> (mintercalate "', '" columnNames) <> "']::text[]") join <$> fetchMaybe fetchPrimaryKey @@ -877,15 +862,16 @@ sqlGetChecks :: Table -> SQL sqlGetChecks table = toSQLCommand . sqlSelect "pg_catalog.pg_constraint c" $ do sqlResult "c.conname::text"- sqlResult "regexp_replace(pg_get_constraintdef(c.oid, true), \- \'CHECK \\((.*)\\)', '\\1') AS body" -- check body+ sqlResult "regexp_replace(pg_get_constraintdef(c.oid, true), 'CHECK \\((.*)\\)', '\\1') AS body" -- check body+ sqlResult "c.convalidated" -- validated? sqlWhereEq "c.contype" 'c' sqlWhereEqSql "c.conrelid" $ sqlGetTableID table -fetchTableCheck :: (String, String) -> Check-fetchTableCheck (name, condition) = Check {+fetchTableCheck :: (String, String, Bool) -> Check+fetchTableCheck (name, condition, validated) = Check { chkName = unsafeSQL name , chkCondition = unsafeSQL condition+, chkValidated = validated } -- *** INDEXES ***@@ -896,6 +882,7 @@ sqlResult $ "ARRAY(" <> selectCoordinates <> ")" -- array of index coordinates sqlResult "am.amname::text" -- the method used (btree, gin etc) sqlResult "i.indisunique" -- is it unique?+ sqlResult "i.indisvalid" -- is it valid? -- if partial, get constraint def sqlResult "pg_catalog.pg_get_expr(i.indpred, i.indrelid, true)" sqlJoinOn "pg_catalog.pg_index i" "c.oid = i.indexrelid"@@ -917,12 +904,13 @@ , "SELECT name FROM coordinates WHERE k > 0" ] -fetchTableIndex :: (String, Array1 String, String, Bool, Maybe String)+fetchTableIndex :: (String, Array1 String, String, Bool, Bool, Maybe String) -> (TableIndex, RawSQL ())-fetchTableIndex (name, Array1 columns, method, unique, mconstraint) = (TableIndex {+fetchTableIndex (name, Array1 columns, method, unique, valid, mconstraint) = (TableIndex { idxColumns = map unsafeSQL columns , idxMethod = read method , idxUnique = unique+, idxValid = valid , idxWhere = unsafeSQL `liftM` mconstraint }, unsafeSQL name) @@ -935,20 +923,16 @@ sqlResult $ "ARRAY(SELECT a.attname::text FROM pg_catalog.pg_attribute a JOIN (" <> unnestWithOrdinality "r.conkey"- <> ") conkeys ON (a.attnum = conkeys.item) \- \WHERE a.attrelid = r.conrelid \- \ORDER BY conkeys.n)" -- constrained columns+ <> ") conkeys ON (a.attnum = conkeys.item) WHERE a.attrelid = r.conrelid ORDER BY conkeys.n)" -- constrained columns sqlResult "c.relname::text" -- referenced table- sqlResult $ "ARRAY(SELECT a.attname::text \- \FROM pg_catalog.pg_attribute a JOIN ("+ sqlResult $ "ARRAY(SELECT a.attname::text FROM pg_catalog.pg_attribute a JOIN (" <> unnestWithOrdinality "r.confkey"- <> ") confkeys ON (a.attnum = confkeys.item) \- \WHERE a.attrelid = r.confrelid \- \ORDER BY confkeys.n)" -- referenced columns+ <> ") confkeys ON (a.attnum = confkeys.item) WHERE a.attrelid = r.confrelid ORDER BY confkeys.n)" -- referenced columns sqlResult "r.confupdtype" -- on update sqlResult "r.confdeltype" -- on delete sqlResult "r.condeferrable" -- deferrable? sqlResult "r.condeferred" -- initially deferred?+ sqlResult "r.convalidated" -- validated? sqlJoinOn "pg_catalog.pg_class c" "c.oid = r.confrelid" sqlWhereEqSql "r.conrelid" $ sqlGetTableID table sqlWhereEq "r.contype" 'f'@@ -959,11 +943,11 @@ <> "[n] AS item FROM generate_subscripts(" <> raw arr <> ", 1) AS n" fetchForeignKey ::- (String, Array1 String, String, Array1 String, Char, Char, Bool, Bool)+ (String, Array1 String, String, Array1 String, Char, Char, Bool, Bool, Bool) -> (ForeignKey, RawSQL ()) fetchForeignKey ( name, Array1 columns, reftable, Array1 refcolumns- , on_update, on_delete, deferrable, deferred ) = (ForeignKey {+ , on_update, on_delete, deferrable, deferred, validated ) = (ForeignKey { fkColumns = map unsafeSQL columns , fkRefTable = unsafeSQL reftable , fkRefColumns = map unsafeSQL refcolumns@@ -971,6 +955,7 @@ , fkOnDelete = charToForeignKeyAction on_delete , fkDeferrable = deferrable , fkDeferred = deferred+, fkValidated = validated }, unsafeSQL name) where charToForeignKeyAction c = case c of@@ -979,5 +964,4 @@ 'c' -> ForeignKeyCascade 'n' -> ForeignKeySetNull 'd' -> ForeignKeySetDefault- _ -> error $ "fetchForeignKey: invalid foreign key action code: "- ++ show c+ _ -> error $ "fetchForeignKey: invalid foreign key action code: " ++ show c
src/Database/PostgreSQL/PQTypes/Checks/Util.hs view
@@ -1,6 +1,10 @@ {-# LANGUAGE CPP #-} module Database.PostgreSQL.PQTypes.Checks.Util (- ValidationResult(..),+ ValidationResult,+ validationError,+ validationInfo,+ mapValidationResult,+ validationErrorsToInfos, resultCheck, topMessage, tblNameText,@@ -28,32 +32,60 @@ import Database.PostgreSQL.PQTypes.Model import Database.PostgreSQL.PQTypes --- | A (potentially empty) list of error messages.-newtype ValidationResult = ValidationResult [Text]+-- | A (potentially empty) list of info/error messages.+data ValidationResult = ValidationResult+ { vrInfos :: [Text]+ , vrErrors :: [Text]+ } +validationError :: Text -> ValidationResult+validationError err = mempty { vrErrors = [err] }++validationInfo :: Text -> ValidationResult+validationInfo msg = mempty { vrInfos = [msg] }++-- | Downgrade all error messages in a ValidationResult to info messages.+validationErrorsToInfos :: ValidationResult -> ValidationResult+validationErrorsToInfos ValidationResult{..} =+ mempty { vrInfos = vrInfos <> vrErrors }++mapValidationResult ::+ ([Text] -> [Text]) -> ([Text] -> [Text]) -> ValidationResult -> ValidationResult+mapValidationResult mapInfos mapErrs ValidationResult{..} =+ mempty { vrInfos = mapInfos vrInfos, vrErrors = mapErrs vrErrors }+ instance SG.Semigroup ValidationResult where- (ValidationResult a) <> (ValidationResult b) = ValidationResult (a ++ b)+ (ValidationResult infos0 errs0) <> (ValidationResult infos1 errs1)+ = ValidationResult (infos0 <> infos1) (errs0 <> errs1) instance Monoid ValidationResult where- mempty = ValidationResult []+ mempty = ValidationResult [] [] mappend = (SG.<>) topMessage :: Text -> Text -> ValidationResult -> ValidationResult-topMessage objtype objname = \case- ValidationResult [] -> ValidationResult []- ValidationResult es -> ValidationResult- ("There are problems with the" <+> objtype <+> "'" <> objname <> "'" : es)+topMessage objtype objname vr@ValidationResult{..} =+ case vrErrors of+ [] -> vr+ es -> ValidationResult vrInfos+ ("There are problems with the" <+>+ objtype <+> "'" <> objname <> "'" : es) +-- | Log all messages in a 'ValidationResult', and fail if any of them+-- were errors. resultCheck :: (MonadLog m, MonadThrow m) => ValidationResult -> m ()-resultCheck = \case- ValidationResult [] -> return ()- ValidationResult msgs -> do- mapM_ logAttention_ msgs- error "resultCheck: validation failed"+resultCheck ValidationResult{..} = do+ mapM_ logInfo_ vrInfos+ case vrErrors of+ [] -> return ()+ msgs -> do+ mapM_ logAttention_ msgs+ error "resultCheck: validation failed" +----------------------------------------+ tblNameText :: Table -> Text tblNameText = unRawSQL . tblName @@ -63,7 +95,7 @@ checkEquality :: (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult checkEquality pname defs props = case (defs L.\\ props, props L.\\ defs) of ([], []) -> mempty- (def_diff, db_diff) -> ValidationResult [mconcat [+ (def_diff, db_diff) -> validationError . mconcat $ [ "Table and its definition have diverged and have " , showt $ length db_diff , " and "@@ -75,7 +107,7 @@ , ", definition: " , T.pack $ show def_diff , ")."- ]]+ ] checkNames :: Show t => (t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult checkNames prop_name = mconcat . map check@@ -83,7 +115,7 @@ check (prop, name) = case prop_name prop of pname | pname == name -> mempty- | otherwise -> ValidationResult [mconcat [+ | otherwise -> validationError . mconcat $ [ "Property " , T.pack $ show prop , " has invalid name (expected: "@@ -91,7 +123,7 @@ , ", given: " , unRawSQL name , ")."- ]]+ ] -- | Check presence of primary key on the named table. We cover all the cases so -- this could be used standalone, but note that the those where the table source@@ -115,10 +147,10 @@ noSrc = "no source definition" noTbl = "no table definition" valRes msgs =- ValidationResult [- mconcat [ "Table ", unRawSQL tableName- , " has no primary key defined "- , " (" <> (mintercalate ", " msgs) <> ")"]]+ validationError . mconcat $+ [ "Table ", unRawSQL tableName+ , " has no primary key defined "+ , " (" <> (mintercalate ", " msgs) <> ")"] tableHasLess :: Show t => Text -> t -> Text
src/Database/PostgreSQL/PQTypes/Migrate.hs view
@@ -17,7 +17,7 @@ -- create the domain runQuery_ $ sqlCreateDomain dom -- add constraint checks to the domain- F.forM_ domChecks $ runQuery_ . sqlAlterDomain domName . sqlAddCheck+ F.forM_ domChecks $ runQuery_ . sqlAlterDomain domName . sqlAddValidCheck createTable :: MonadDB m => Bool -> Table -> m () createTable withConstraints table@Table{..} = do@@ -25,7 +25,7 @@ runQuery_ $ sqlCreateTable tblName runQuery_ $ sqlAlterTable tblName $ map sqlAddColumn tblColumns -- Add indexes.- forM_ tblIndexes $ runQuery_ . sqlCreateIndex tblName+ forM_ tblIndexes $ runQuery_ . sqlCreateIndexSequentially tblName -- Add all the other constraints if applicable. when withConstraints $ createTableConstraints table -- Register the table along with its version.@@ -39,6 +39,6 @@ where addConstraints = concat [ [sqlAddPK tblName pk | Just pk <- return tblPrimaryKey]- , map sqlAddCheck tblChecks- , map (sqlAddFK tblName) tblForeignKeys+ , map sqlAddValidCheck tblChecks+ , map (sqlAddValidFK tblName) tblForeignKeys ]
src/Database/PostgreSQL/PQTypes/Model/Check.hs view
@@ -1,6 +1,10 @@ module Database.PostgreSQL.PQTypes.Model.Check ( Check(..)+ , tblCheck , sqlAddCheck+ , sqlAddValidCheck+ , sqlAddNotValidCheck+ , sqlValidateCheck , sqlDropCheck ) where @@ -11,16 +15,48 @@ data Check = Check { chkName :: RawSQL () , chkCondition :: RawSQL ()+, chkValidated :: Bool -- ^ Set to 'True' if check is created as NOT VALID and+ -- not validated afterwards. } deriving (Eq, Ord, Show) +tblCheck :: Check+tblCheck = Check+ { chkName = ""+ , chkCondition = ""+ , chkValidated = True+ }++{-# DEPRECATED sqlAddCheck "Use sqlAddValidCheck instead" #-}+-- | Deprecated version of 'sqlAddValidCheck'. sqlAddCheck :: Check -> RawSQL ()-sqlAddCheck Check{..} = smconcat [+sqlAddCheck = sqlAddCheck_ True++-- | Add valid check constraint. Warning: PostgreSQL acquires SHARE ROW+-- EXCLUSIVE lock (that prevents updates) on modified table for the duration of+-- the creation. If this is not acceptable, use 'sqlAddNotValidCheck' and+-- 'sqlValidateCheck'.+sqlAddValidCheck :: Check -> RawSQL ()+sqlAddValidCheck = sqlAddCheck_ True++-- | Add check marked as NOT VALID. This avoids potentially long validation+-- blocking updates to modified table for its duration. However, checks created+-- as such need to be validated later using 'sqlValidateCheck'.+sqlAddNotValidCheck :: Check -> RawSQL ()+sqlAddNotValidCheck = sqlAddCheck_ False++-- | Validate check previously created as NOT VALID.+sqlValidateCheck :: Check -> RawSQL ()+sqlValidateCheck Check{..} = "VALIDATE" <+> chkName++sqlAddCheck_ :: Bool -> Check -> RawSQL ()+sqlAddCheck_ valid Check{..} = smconcat [ "ADD CONSTRAINT" , chkName , "CHECK (" , chkCondition , ")"+ , if valid then "" else " NOT VALID" ] -sqlDropCheck :: Check -> RawSQL ()-sqlDropCheck Check{..} = "DROP CONSTRAINT" <+> chkName+sqlDropCheck :: RawSQL () -> RawSQL ()+sqlDropCheck name = "DROP CONSTRAINT" <+> name
src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs view
@@ -5,6 +5,9 @@ , fkOnColumns , fkName , sqlAddFK+ , sqlAddValidFK+ , sqlAddNotValidFK+ , sqlValidateFK , sqlDropFK ) where @@ -22,6 +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. } deriving (Eq, Ord, Show) data ForeignKeyAction@@ -45,6 +50,7 @@ , fkOnDelete = ForeignKeyNoAction , fkDeferrable = True , fkDeferred = False+, fkValidated = True } fkName :: RawSQL () -> ForeignKey -> RawSQL ()@@ -60,8 +66,31 @@ -- PostgreSQL's limit for identifier is 63 characters shorten = flip rawSQL () . T.take 63 . unRawSQL +{-# DEPRECATED sqlAddFK "Use sqlAddValidFK instead" #-}+-- | Deprecated version of sqlAddValidFK. sqlAddFK :: RawSQL () -> ForeignKey -> RawSQL ()-sqlAddFK tname fk@ForeignKey{..} = mconcat [+sqlAddFK = sqlAddFK_ True++-- | Add valid foreign key. Warning: PostgreSQL acquires SHARE ROW EXCLUSIVE+-- lock (that prevents data updates) on both modified and referenced table for+-- the duration of the creation. If this is not acceptable, use+-- 'sqlAddNotValidFK' and 'sqlValidateFK'.+sqlAddValidFK :: RawSQL () -> ForeignKey -> RawSQL ()+sqlAddValidFK = sqlAddFK_ True++-- | Add foreign key marked as NOT VALID. This avoids potentially long+-- validation blocking updates to both modified and referenced table for its+-- duration. However, keys created as such need to be validated later using+-- 'sqlValidateFK'.+sqlAddNotValidFK :: RawSQL () -> ForeignKey -> RawSQL ()+sqlAddNotValidFK = sqlAddFK_ False++-- | Validate foreign key previously created as NOT VALID.+sqlValidateFK :: RawSQL () -> ForeignKey -> RawSQL ()+sqlValidateFK tname fk = "VALIDATE" <+> fkName tname fk++sqlAddFK_ :: Bool -> RawSQL () -> ForeignKey -> RawSQL ()+sqlAddFK_ valid tname fk@ForeignKey{..} = mconcat [ "ADD CONSTRAINT" <+> fkName tname fk <+> "FOREIGN KEY (" , mintercalate ", " fkColumns , ") REFERENCES" <+> fkRefTable <+> "("@@ -70,6 +99,7 @@ , " ON DELETE" <+> foreignKeyActionToSQL fkOnDelete , " " <> if fkDeferrable then "DEFERRABLE" else "NOT DEFERRABLE" , " INITIALLY" <+> if fkDeferred then "DEFERRED" else "IMMEDIATE"+ , if valid then "" else " NOT VALID" ] where foreignKeyActionToSQL ForeignKeyNoAction = "NO ACTION"
src/Database/PostgreSQL/PQTypes/Model/Index.hs view
@@ -11,6 +11,8 @@ , uniqueIndexOnColumns , indexName , sqlCreateIndex+ , sqlCreateIndexSequentially+ , sqlCreateIndexConcurrently , sqlDropIndex ) where @@ -29,6 +31,9 @@ idxColumns :: [RawSQL ()] , idxMethod :: IndexMethod , idxUnique :: Bool+, idxValid :: Bool -- ^ If creation of index with CONCURRENTLY fails, index+ -- will be marked as invalid. Set it to 'False' if such+ -- situation is expected. , idxWhere :: Maybe (RawSQL ()) } deriving (Eq, Ord, Show) @@ -51,6 +56,7 @@ idxColumns = [] , idxMethod = BTree , idxUnique = False+, idxValid = True , idxWhere = Nothing } @@ -80,6 +86,7 @@ idxColumns = [column] , idxMethod = BTree , idxUnique = True+, idxValid = True , idxWhere = Nothing } @@ -88,6 +95,7 @@ idxColumns = columns , idxMethod = BTree , idxUnique = True+, idxValid = True , idxWhere = Nothing } @@ -96,6 +104,7 @@ idxColumns = [column] , idxMethod = BTree , idxUnique = True+, idxValid = True , idxWhere = Just whereC } @@ -122,11 +131,30 @@ -- with the same columns, but different constraints can coexist hashWhere = asText $ T.decodeUtf8 . encode . BS.take 10 . hash . T.encodeUtf8 +{-# DEPRECATED sqlCreateIndex "Use sqlCreateIndexSequentially instead" #-}+-- | Deprecated version of 'sqlCreateIndexSequentially'. sqlCreateIndex :: RawSQL () -> TableIndex -> RawSQL ()-sqlCreateIndex tname idx@TableIndex{..} = mconcat [+sqlCreateIndex = sqlCreateIndex_ False++-- | Create index sequentially. Warning: if the affected table is large, this+-- will prevent the table from being modified during the creation. If this is+-- not acceptable, use sqlCreateIndexConcurrently. See+-- https://www.postgresql.org/docs/current/sql-createindex.html for more+-- information.+sqlCreateIndexSequentially :: RawSQL () -> TableIndex -> RawSQL ()+sqlCreateIndexSequentially = sqlCreateIndex_ False++-- | Create index concurrently.+sqlCreateIndexConcurrently :: RawSQL () -> TableIndex -> RawSQL ()+sqlCreateIndexConcurrently = sqlCreateIndex_ True++sqlCreateIndex_ :: Bool -> RawSQL () -> TableIndex -> RawSQL ()+sqlCreateIndex_ concurrently tname idx@TableIndex{..} = mconcat [ "CREATE " , if idxUnique then "UNIQUE " else ""- , "INDEX" <+> indexName tname idx <+> "ON" <+> tname <+> ""+ , "INDEX " <+> indexName tname idx+ , if concurrently then " CONCURRENTLY" else ""+ , " ON" <+> tname <+> "" , "USING" <+> (rawSQL (T.pack . show $ idxMethod) ()) <+> "(" , mintercalate ", " idxColumns , ")"
src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs view
@@ -4,6 +4,7 @@ , pkOnColumns , pkName , sqlAddPK+ , sqlAddPKUsing , sqlDropPK ) where @@ -11,6 +12,7 @@ import Data.Monoid.Utils import Database.PostgreSQL.PQTypes import Prelude+import Database.PostgreSQL.PQTypes.Model.Index import Database.PostgreSQL.PQTypes.Utils.NubList newtype PrimaryKey = PrimaryKey (NubList (RawSQL ()))@@ -33,6 +35,18 @@ , "PRIMARY KEY (" , mintercalate ", " $ fromNubList columns , ")"+ ]++-- | Convert a unique index into a primary key. Main usage is to build a unique+-- index concurrently first (so that its creation doesn't conflict with table+-- updates on the modified table) and then convert it into a primary key using+-- this function.+sqlAddPKUsing :: RawSQL () -> TableIndex -> RawSQL ()+sqlAddPKUsing tname idx = smconcat+ [ "ADD CONSTRAINT"+ , pkName tname+ , "PRIMARY KEY USING INDEX"+ , indexName tname idx ] sqlDropPK :: RawSQL () -> RawSQL ()
src/Database/PostgreSQL/PQTypes/Model/Table.hs view
@@ -63,14 +63,19 @@ data Table = Table {- tblName :: RawSQL () -- ^ Must be in lower case.-, tblVersion :: Int32-, tblColumns :: [TableColumn]-, tblPrimaryKey :: Maybe PrimaryKey-, tblChecks :: [Check]-, tblForeignKeys :: [ForeignKey]-, tblIndexes :: [TableIndex]-, tblInitialSetup :: Maybe TableInitialSetup+ tblName :: RawSQL () -- ^ Must be in lower case.+, tblVersion :: Int32+, tblAcceptedDbVersions :: [Int32] -- ^ List of database table versions that+ -- will be accepted even if they don't match+ -- the table definition (note that in such+ -- case structural differences are not+ -- errors).+, tblColumns :: [TableColumn]+, tblPrimaryKey :: Maybe PrimaryKey+, tblChecks :: [Check]+, tblForeignKeys :: [ForeignKey]+, tblIndexes :: [TableIndex]+, tblInitialSetup :: Maybe TableInitialSetup } data TableInitialSetup = TableInitialSetup {@@ -82,6 +87,7 @@ tblTable = Table { tblName = error "tblTable: table name must be specified" , tblVersion = error "tblTable: table version must be specified"+, tblAcceptedDbVersions = [] , tblColumns = error "tblTable: table columns must be specified" , tblPrimaryKey = Nothing , tblChecks = []
test/Main.hs view
@@ -6,7 +6,6 @@ import Control.Monad.Trans.Control import Data.Monoid-import Prelude import Data.Int import qualified Data.Text as T import Data.Typeable@@ -413,12 +412,12 @@ schema6Migrations :: (MonadDB m) => Migration m schema6Migrations = Migration- { mgrTableName = tblName tableParticipatedInRobberySchema1+ {+ mgrTableName = tblName tableParticipatedInRobberySchema1 , mgrFrom = tblVersion tableParticipatedInRobberySchema1- , mgrAction =- StandardMigration $ do- runQuery_ $ ("ALTER TABLE participated_in_robbery DROP CONSTRAINT \- \pk__participated_in_robbery" :: RawSQL ())+ , mgrAction = StandardMigration $ do+ runQuery_ $ ("ALTER TABLE participated_in_robbery DROP CONSTRAINT " <>+ "pk__participated_in_robbery" :: RawSQL ()) } @@ -530,8 +529,7 @@ let extrasOptions = def extensions = [] domains = []- step "Hackily migrating the database (schema version 1 \- \-> schema version 2)..."+ step "Hackily migrating the database (schema version 1 -> schema version 2)..." migrateDatabase extrasOptions extensions domains schema2Tables schema2Migrations' checkDatabase extrasOptions domains schema2Tables@@ -689,9 +687,11 @@ runSQL_ "DROP SCHEMA public CASCADE" runSQL_ "CREATE SCHEMA public" --- | Re-used by 'migrationTest5'.-migrationTest1Body :: (String -> TestM ()) -> TestM ()-migrationTest1Body step = do+migrationTest1 :: ConnectionSourceM (LogT IO) -> TestTree+migrationTest1 connSource =+ testCaseSteps' "Migration test 1" connSource $ \step -> do+ freshTestDB step+ createTablesSchema1 step (badGuyIds, robberyIds) <- testDBSchema1 step@@ -708,16 +708,8 @@ migrateDBToSchema5 step testDBSchema5 step --migrationTest1 :: ConnectionSourceM (LogT IO) -> TestTree-migrationTest1 connSource =- testCaseSteps' "Migration test 1" connSource $ \step -> do freshTestDB step - migrationTest1Body step-- freshTestDB step- -- | Test for behaviour of 'checkDatabase' and 'checkDatabaseAllowUnknownTables' migrationTest2 :: ConnectionSourceM (LogT IO) -> TestTree migrationTest2 connSource =@@ -730,21 +722,19 @@ extrasOptions = def { eoEnforcePKs = True } assertNoException "checkDatabase should run fine for consistent DB" $ checkDatabase extrasOptions [] currentSchema- assertNoException "checkDatabaseAllowUnknownTables runs fine \- \for consistent DB" $+ assertNoException "checkDatabaseAllowUnknownTables runs fine for consistent DB" $ checkDatabaseAllowUnknownTables extrasOptions [] currentSchema- assertException "checkDatabase should throw exception for wrong schema" $+ assertException "checkDatabase should throw exception for wrong scheme" $ checkDatabase extrasOptions [] differentSchema- assertException ("checkDatabaseAllowUnknownTables \- \should throw exception for wrong scheme") $+ assertException ("checkDatabaseAllowUnknownTables "+ ++ "should throw exception for wrong scheme") $ checkDatabaseAllowUnknownTables extrasOptions [] differentSchema - runSQL_ "INSERT INTO table_versions (name, version) \- \VALUES ('unknown_table', 0)"+ runSQL_ "INSERT INTO table_versions (name, version) VALUES ('unknown_table', 0)" assertException "checkDatabase throw when extra entry in 'table_versions'" $ checkDatabase extrasOptions [] currentSchema- assertNoException ("checkDatabaseAllowUnknownTables \- \accepts extra entry in 'table_versions'") $+ assertNoException ("checkDatabaseAllowUnknownTables "+ ++ "accepts extra entry in 'table_versions'") $ checkDatabaseAllowUnknownTables extrasOptions [] currentSchema runSQL_ "DELETE FROM table_versions where name='unknown_table'" @@ -754,12 +744,11 @@ assertNoException "checkDatabaseAllowUnknownTables accepts unknown table" $ checkDatabaseAllowUnknownTables extrasOptions [] currentSchema - runSQL_ "INSERT INTO table_versions (name, version) \- \VALUES ('unknown_table', 0)"+ runSQL_ "INSERT INTO table_versions (name, version) VALUES ('unknown_table', 0)" assertException "checkDatabase should throw with unknown table" $ checkDatabase extrasOptions [] currentSchema- assertNoException ("checkDatabaseAllowUnknownTables \- \accepts unknown tables with version") $+ assertNoException ("checkDatabaseAllowUnknownTables "+ ++ "accepts unknown tables with version") $ checkDatabaseAllowUnknownTables extrasOptions [] currentSchema freshTestDB step@@ -772,17 +761,14 @@ step "Recreating the database (schema version 1, one table is missing PK)..." - migrateDatabase optionsNoPKCheck [] []- schema1TablesWithMissingPK [schema1MigrationsWithMissingPK]+ migrateDatabase optionsNoPKCheck [] [] schema1TablesWithMissingPK [schema1MigrationsWithMissingPK] checkDatabase optionsNoPKCheck [] withMissingPKSchema - assertException- "checkDatabase should throw when PK missing from table \- \'participated_in_robbery' and check is enabled" $+ assertException ("checkDatabase should throw when PK missing from table " <>+ "'participated_in_robbery' and check is enabled") $ checkDatabase optionsWithPKCheck [] withMissingPKSchema- assertNoException- "checkDatabase should not throw when PK missing from table \- \'participated_in_robbery' and check is disabled" $+ assertNoException ("checkDatabase should not throw when PK missing from table " <>+ "'participated_in_robbery' and check is disabled") $ checkDatabase optionsNoPKCheck [] withMissingPKSchema freshTestDB step@@ -799,27 +785,12 @@ migrateDBToSchema2 step testDBSchema2 step badGuyIds robberyIds - assertException ( "Trying to run the same migration twice should fail, \- \when starting with a createTable migration" ) $+ assertException ( "Trying to run the same migration twice should fail, "+ ++ "when starting with a createTable migration" ) $ migrateDBToSchema2Hacky step freshTestDB step --- | Test that running the same migrations twice doesn't result in--- unexpected errors.-migrationTest4 :: ConnectionSourceM (LogT IO) -> TestTree-migrationTest4 connSource =- testCaseSteps' "Migration test 4" connSource $ \step -> do- freshTestDB step-- migrationTest1Body step-- -- Here we run step 5 for the second time. This should be a no-op.- migrateDBToSchema5 step- testDBSchema5 step-- freshTestDB step- eitherExc :: MonadBaseControl IO m => (SomeException -> m ()) -> (a -> m ()) -> m a -> m () eitherExc left right c = (E.try c) >>= either left right@@ -856,7 +827,6 @@ testGroup "DB tests" [ migrationTest1 connSource , migrationTest2 connSource , migrationTest3 connSource- , migrationTest4 connSource ] where ings =