hpqtypes-extras 1.6.3.0 → 1.6.4.0
raw patch · 4 files changed
+130/−58 lines, 4 files
Files
- CHANGELOG.md +5/−1
- hpqtypes-extras.cabal +2/−2
- src/Database/PostgreSQL/PQTypes/Checks.hs +65/−27
- test/Main.hs +58/−28
CHANGELOG.md view
@@ -1,4 +1,8 @@-# hpqtypes-extras-1.6.3.0 (2018-07-11)+# 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` ([#16](https://github.com/scrive/hpqtypes-extras/pull/16)).
hpqtypes-extras.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: hpqtypes-extras-version: 1.6.3.0+version: 1.6.4.0 synopsis: Extra utilities for hpqtypes library description: The following extras for hpqtypes library: .@@ -20,7 +20,7 @@ copyright: Scrive AB category: Database build-type: Simple-tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.2+tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3 Source-repository head Type: git
src/Database/PostgreSQL/PQTypes/Checks.hs view
@@ -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 -- 'checkDBConsistency' also performs migrations.@@ -204,7 +206,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 . ValidationResult $ (joinedResult "Unknown entry in table_versions':" absent ) ++ (joinedResult "Tables not present in the 'table_versions':" notPresent)@@ -318,7 +321,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@@ -326,7 +330,8 @@ , 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]@@ -336,8 +341,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)@@ -451,7 +457,7 @@ where - errorInvalidMigrations :: [RawSQL ()] -> a+ errorInvalidMigrations :: HasCallStack => [RawSQL ()] -> a errorInvalidMigrations tblNames = error $ "checkDBConsistency: invalid migrations for tables" <+> (L.intercalate ", " $ map (T.unpack . unRawSQL) tblNames)@@ -494,8 +500,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@@ -516,8 +523,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 ()@@ -541,7 +549,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) ->@@ -571,7 +580,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]@@ -582,7 +592,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 @@ -596,7 +607,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 $@@ -609,13 +621,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 ()@@ -796,7 +824,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@@ -833,7 +863,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 @@ -846,7 +877,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 sqlWhereEq "c.contype" 'c' sqlWhereEqSql "c.conrelid" $ sqlGetTableID table @@ -903,11 +935,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?@@ -942,4 +979,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
test/Main.hs view
@@ -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 =