diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# hpqtypes-extras-1.7.1.0 (2019-02-04) +* Fix an issue where unnecessary migrations were run sometimes + ([#18](https://github.com/scrive/hpqtypes-extras/pull/18)). + # hpqtypes-extras-1.7.0.0 (2019-01-08) * Added support for no-downtime migrations ([#17](https://github.com/scrive/hpqtypes-extras/pull/17)): @@ -17,6 +21,10 @@ - New `Table` field: `tblAcceptedDbVersions`. * `ValidationResult` is now an abstract type. * `ValidationResult` now supports info-level messages in addition to errors. + +# 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.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.7.0.0 +version: 1.7.1.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,6 +24,7 @@ import qualified Data.String import Data.Text (Text) import Database.PostgreSQL.PQTypes hiding (def) +import GHC.Stack (HasCallStack) import Log import Prelude import TextShow @@ -48,7 +49,8 @@ :: (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) @@ -213,7 +215,8 @@ 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 + 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) @@ -225,25 +228,37 @@ checkDomainsStructure defs = fmap mconcat . forM defs $ \def -> do runQuery_ . sqlSelect "pg_catalog.pg_type t1" $ do sqlResult "t1.typname::text" -- name - sqlResult "(SELECT pg_catalog.format_type(t2.oid, t2.typtypmod) FROM pg_catalog.pg_type t2 WHERE t2.oid = t1.typbasetype)" -- type + sqlResult "(SELECT pg_catalog.format_type(t2.oid, t2.typtypmod) \ + \FROM pg_catalog.pg_type t2 \ + \WHERE t2.oid = t1.typbasetype)" -- type sqlResult "NOT t1.typnotnull" -- nullable 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? + 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, valids) -> - Domain { - domName = unsafeSQL dname - , domType = dtype - , domNullable = nullable - , domDefault = unsafeSQL <$> defval - , domChecks = mkChecks $ zipWith3 (\cname cond validated -> Check { - chkName = unsafeSQL cname - , chkCondition = unsafeSQL cond - , chkValidated = validated - }) (unArray1 cnames) (unArray1 conds) (unArray1 valids) - } + mdom <- fetchMaybe $ + \(dname, dtype, nullable, defval, cnames, conds, valids) -> + Domain + { domName = unsafeSQL dname + , domType = dtype + , domNullable = nullable + , domDefault = unsafeSQL <$> defval + , domChecks = + mkChecks $ zipWith3 + (\cname cond validated -> + Check + { chkName = unsafeSQL cname + , chkCondition = unsafeSQL cond + , chkValidated = validated + }) (unArray1 cnames) (unArray1 conds) (unArray1 valids) + } return $ case mdom of Just dom | dom /= def -> topMessage "domain" (unRawSQL $ domName dom) $ mconcat [ @@ -288,7 +303,8 @@ => ExtrasOptions -> [(Table, Int32)] -> m ValidationResult -checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) -> +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 @@ -332,7 +348,8 @@ , 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 @@ -340,7 +357,8 @@ , colDefault = unsafeSQL `liftM` mdefault } - checkColumns :: Int -> [TableColumn] -> [TableColumn] -> ValidationResult + checkColumns + :: Int -> [TableColumn] -> [TableColumn] -> ValidationResult checkColumns _ [] [] = mempty checkColumns _ rest [] = validationError $ tableHasLess "columns" rest checkColumns _ [] rest = validationError $ tableHasMore "columns" rest @@ -350,8 +368,9 @@ -- 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 implicitely specified by db, so let's omit them in such case + -- 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. , validateDefaults $ colDefault d == colDefault c || (colDefault d == Nothing && ((T.isPrefixOf "nextval('" . unRawSQL) `liftM` colDefault c) @@ -470,7 +489,7 @@ where tables = map fst tablesWithVersions - errorInvalidMigrations :: [RawSQL ()] -> a + errorInvalidMigrations :: HasCallStack => [RawSQL ()] -> a errorInvalidMigrations tblNames = error $ "checkDBConsistency: invalid migrations for tables" <+> (L.intercalate ", " $ map (T.unpack . unRawSQL) tblNames) @@ -513,8 +532,9 @@ <> "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 @@ -535,8 +555,9 @@ 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 () @@ -560,7 +581,8 @@ 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) -> @@ -590,7 +612,8 @@ 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] @@ -601,7 +624,8 @@ 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 @@ -615,7 +639,8 @@ -- 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 $ @@ -628,13 +653,29 @@ -- we've found. -- -- Case in point: createTable t, doSomethingTo t, - -- doSomethingTo t1, dropTable t. - l = length migrationsToRun' - initialMigrations = drop l $ reverse migrations - additionalMigrations = takeWhile + -- 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 (\mgr -> droppedEventually mgr && tableDoesNotExist mgr) initialMigrations - migrationsToRun = (reverse additionalMigrations) ++ migrationsToRun' + -- 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 [] in migrationsToRun runMigration :: (Migration m) -> m () @@ -812,7 +853,9 @@ -- *** 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 @@ -849,7 +892,8 @@ 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 @@ -862,7 +906,8 @@ 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 @@ -906,13 +951,15 @@ fetchTableIndex :: (String, Array1 String, String, Bool, Bool, Maybe String) -> (TableIndex, RawSQL ()) -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) +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) -- *** FOREIGN KEYS *** @@ -923,11 +970,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? @@ -964,4 +1016,5 @@ '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/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -6,6 +6,7 @@ import Control.Monad.Trans.Control import Data.Monoid +import Prelude import Data.Int import qualified Data.Text as T import Data.Typeable @@ -412,12 +413,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 ()) } @@ -529,7 +530,8 @@ 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 @@ -687,11 +689,9 @@ runSQL_ "DROP SCHEMA public CASCADE" runSQL_ "CREATE SCHEMA public" -migrationTest1 :: ConnectionSourceM (LogT IO) -> TestTree -migrationTest1 connSource = - testCaseSteps' "Migration test 1" connSource $ \step -> do - freshTestDB step - +-- | Re-used by 'migrationTest5'. +migrationTest1Body :: (String -> TestM ()) -> TestM () +migrationTest1Body step = do createTablesSchema1 step (badGuyIds, robberyIds) <- testDBSchema1 step @@ -708,8 +708,16 @@ 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 = @@ -722,19 +730,21 @@ 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 scheme" $ + assertException "checkDatabase should throw exception for wrong schema" $ 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'" @@ -744,11 +754,12 @@ 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 @@ -761,14 +772,17 @@ 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 @@ -785,12 +799,27 @@ 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 @@ -827,6 +856,7 @@ testGroup "DB tests" [ migrationTest1 connSource , migrationTest2 connSource , migrationTest3 connSource + , migrationTest4 connSource ] where ings =