diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` 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.6.4.0 +version: 1.7.0.0 synopsis: Extra utilities for hpqtypes library description: The following extras for hpqtypes library: . 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 @@ -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 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 @@ -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 diff --git a/src/Database/PostgreSQL/PQTypes/Migrate.hs b/src/Database/PostgreSQL/PQTypes/Migrate.hs --- a/src/Database/PostgreSQL/PQTypes/Migrate.hs +++ b/src/Database/PostgreSQL/PQTypes/Migrate.hs @@ -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 ] 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 @@ -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 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 @@ -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" 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 @@ -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 , ")" diff --git a/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs b/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs --- a/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs @@ -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 () diff --git a/src/Database/PostgreSQL/PQTypes/Model/Table.hs b/src/Database/PostgreSQL/PQTypes/Model/Table.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Table.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Table.hs @@ -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 = [] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 =