hpqtypes-extras 1.3.0.0 → 1.3.1.0
raw patch · 3 files changed
+125/−38 lines, 3 filesdep ~monad-controlPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: monad-control
API changes (from Hackage documentation)
Files
- hpqtypes-extras.cabal +2/−1
- src/Database/PostgreSQL/PQTypes/Checks.hs +60/−9
- test/Main.hs +63/−28
hpqtypes-extras.cabal view
@@ -1,5 +1,5 @@ name: hpqtypes-extras-version: 1.3.0.0+version: 1.3.1.0 synopsis: Extra utilities for hpqtypes library description: The following extras for hpqtypes library: .@@ -98,6 +98,7 @@ hpqtypes-extras, lifted-base, log,+ monad-control, tasty, tasty-hunit, text,
src/Database/PostgreSQL/PQTypes/Checks.hs view
@@ -33,6 +33,10 @@ import Database.PostgreSQL.PQTypes.SQL.Builder import Database.PostgreSQL.PQTypes.Versions +headExc :: String -> [a] -> a+headExc s [] = error s+headExc _ (x:_) = x+ ---------------------------------------- -- | Run migrations and check the database structure.@@ -645,34 +649,81 @@ validateMigrationsToRun :: [Migration m] -> [(Text, Int32)] -> m () validateMigrationsToRun migrationsToRun dbTablesWithVersions = do- let migrationsToRunGrouped =++ let migrationsToRunGrouped :: [[Migration m]]+ migrationsToRunGrouped = L.groupBy ((==) `on` mgrTableName) . L.sortBy (comparing mgrTableName) $ -- NB: stable sort migrationsToRun++ loc_common = "Database.PostgreSQL.PQTypes.Checks."+ ++ "checkDBConsistency.validateMigrationsToRun"++ lookupDBTableVer :: [Migration m] -> Maybe Int32+ lookupDBTableVer mgrGroup =+ lookup (unRawSQL . mgrTableName . headExc head_err+ $ mgrGroup) dbTablesWithVersions+ where+ head_err = loc_common ++ ".lookupDBTableVer: broken invariant"++ groupsWithWrongDBTableVersions :: [([Migration m], Int32)]+ groupsWithWrongDBTableVersions =+ [ (mgrGroup, dbTableVer)+ | mgrGroup <- migrationsToRunGrouped+ , let dbTableVer = fromMaybe 0 $ lookupDBTableVer mgrGroup+ , dbTableVer /= (mgrFrom . headExc head_err $ mgrGroup)+ ]+ where+ head_err = loc_common+ ++ ".groupsWithWrongDBTableVersions: broken invariant"++ mgrGroupsNotInDB :: [[Migration m]] mgrGroupsNotInDB = [ mgrGroup | mgrGroup <- migrationsToRunGrouped- , isNothing $- lookup (unRawSQL . mgrTableName . head $ mgrGroup)- dbTablesWithVersions+ , isNothing $ lookupDBTableVer mgrGroup ]++ groupsStartingWithDropTable :: [[Migration m]] groupsStartingWithDropTable = [ mgrGroup | mgrGroup <- mgrGroupsNotInDB- , isDropTableMigration $ head mgrGroup+ , isDropTableMigration . headExc head_err $ mgrGroup ]+ where+ head_err = loc_common+ ++ ".groupsStartingWithDropTable: broken invariant"++ groupsNotStartingWithCreateTable :: [[Migration m]] groupsNotStartingWithCreateTable = [ mgrGroup | mgrGroup <- mgrGroupsNotInDB- , mgrFrom (head mgrGroup) /= 0+ , mgrFrom (headExc head_err mgrGroup) /= 0 ]+ where+ head_err = loc_common+ ++ ".groupsNotStartingWithCreateTable: broken invariant"++ tblNames :: [[Migration m]] -> [RawSQL ()] tblNames grps =- [ mgrTableName . head $ grp | grp <- grps ]+ [ mgrTableName . headExc head_err $ grp | grp <- grps ]+ where+ head_err = loc_common ++ ".tblNames: broken invariant" + when (not . null $ groupsWithWrongDBTableVersions) $ do+ let tnms = tblNames . map fst $ groupsWithWrongDBTableVersions+ logAttention+ ("There are migration chains selected for execution "+ <> "that expect a different starting table version number "+ <> "from the one in the database. "+ <> "This likely means that the order of migrations is wrong.")+ $ object [ "tables" .= map unRawSQL tnms ]+ errorInvalidMigrations tnms+ when (not . null $ groupsStartingWithDropTable) $ do let tnms = tblNames groupsStartingWithDropTable logAttention "There are drop table migrations for non-existing tables."- $ object [ "tables" .= [ unRawSQL tn | tn <- tnms ] ]+ $ object [ "tables" .= map unRawSQL tnms ] errorInvalidMigrations tnms -- NB: the following check can break if we allow renaming tables.@@ -681,7 +732,7 @@ logAttention ("Some tables haven't been created yet, but" <> "their migration lists don't start with a create table migration.")- $ object [ "tables" .= [ unRawSQL tn | tn <- tnms ] ]+ $ object [ "tables" .= map unRawSQL tnms ] errorInvalidMigrations tnms
test/Main.hs view
@@ -3,6 +3,7 @@ import Control.Exception.Lifted as E import Control.Monad.IO.Class+import Control.Monad.Trans.Control import Data.Monoid import Data.Int@@ -492,6 +493,16 @@ schema2Tables schema2Migrations checkDatabase {- domains -} [] schema2Tables +-- | Hacky version of 'migrateDBToSchema2' used by 'migrationTest3'.+migrateDBToSchema2Hacky :: (String -> TestM ()) -> TestM ()+migrateDBToSchema2Hacky step = do+ step "Hackily migrating the database (schema version 1 -> schema version 2)..."+ migrateDatabase {- options -} [] {- extensions -} [] {- domains -} []+ schema2Tables schema2Migrations'+ checkDatabase {- domains -} [] schema2Tables+ where+ schema2Migrations' = createTableMigration tableFlash : schema2Migrations+ testDBSchema2 :: (String -> TestM ()) -> [Int64] -> [Int64] -> TestM () testDBSchema2 step badGuyIds robberyIds = do step "Running test queries (schema version 2)..."@@ -661,58 +672,81 @@ migrationTest2 :: ConnectionSourceM (LogT IO) -> TestTree migrationTest2 connSource = testCaseSteps' "Migration test 2" connSource $ \step -> do- freshTestDB step+ freshTestDB step createTablesSchema1 step- let currentSchema = schema1Tables+ let currentSchema = schema1Tables differentSchema = schema5Tables assertNoException "checkDatabase should run fine for consistent DB" $- (checkDatabase [] currentSchema)+ checkDatabase [] currentSchema assertNoException "checkDatabaseAllowUnknownTables runs fine for consistent DB" $- (checkDatabaseAllowUnknownTables [] currentSchema)+ checkDatabaseAllowUnknownTables [] currentSchema assertException "checkDatabase should throw exception for wrong scheme" $- (checkDatabase [] differentSchema)- assertException "checkDatabaseAllowUnknownTables should throw exception for wrong scheme" $- (checkDatabaseAllowUnknownTables [] differentSchema)+ checkDatabase [] differentSchema+ assertException ("checkDatabaseAllowUnknownTables "+ ++ "should throw exception for wrong scheme") $+ checkDatabaseAllowUnknownTables [] differentSchema runSQL_ "INSERT INTO table_versions (name, version) VALUES ('unknown_table', 0)" assertException "checkDatabase throw when extra entry in 'table_versions'" $- (checkDatabase [] currentSchema)- assertNoException "checkDatabaseAllowUnknownTables accepts extra entry in 'table_versions'" $- (checkDatabaseAllowUnknownTables [] currentSchema)+ checkDatabase [] currentSchema+ assertNoException ("checkDatabaseAllowUnknownTables "+ ++ "accepts extra entry in 'table_versions'") $+ checkDatabaseAllowUnknownTables [] currentSchema runSQL_ "DELETE FROM table_versions where name='unknown_table'" runSQL_ "CREATE TABLE unknown_table (title text)" assertException "checkDatabase should throw with unknown table" $- (checkDatabase [] currentSchema)+ checkDatabase [] currentSchema assertNoException "checkDatabaseAllowUnknownTables accepts unknown table" $- (checkDatabaseAllowUnknownTables [] currentSchema)+ checkDatabaseAllowUnknownTables [] currentSchema runSQL_ "INSERT INTO table_versions (name, version) VALUES ('unknown_table', 0)" assertException "checkDatabase should throw with unknown table" $- (checkDatabase [] currentSchema)- assertNoException "checkDatabaseAllowUnknownTables accepts unknown tables with version" $- (checkDatabaseAllowUnknownTables [] currentSchema)+ checkDatabase [] currentSchema+ assertNoException ("checkDatabaseAllowUnknownTables "+ ++ "accepts unknown tables with version") $+ checkDatabaseAllowUnknownTables [] currentSchema + freshTestDB step++migrationTest3 :: ConnectionSourceM (LogT IO) -> TestTree+migrationTest3 connSource =+ testCaseSteps' "Migration test 3" connSource $ \step -> do freshTestDB step - where- assertNoException :: String -> TestM () -> TestM ()- assertNoException t c = (E.try c) >>= \r -> case r of- Left (_ :: SomeException) ->- liftIO $ assertFailure ("Exception thrown for: " ++ t)- Right _ -> return ()- assertException :: String -> TestM () -> TestM ()- assertException t c = (E.try c) >>= \r -> case r of- Left (_ :: SomeException) -> return ()- Right _ ->- liftIO $ assertFailure ("No exception thrown for: " ++ t)+ createTablesSchema1 step+ (badGuyIds, robberyIds) <-+ testDBSchema1 step + migrateDBToSchema2 step+ testDBSchema2 step badGuyIds robberyIds++ assertException ( "Trying to run the same migration twice should fail, "+ ++ "when starting with a createTable migration" ) $+ migrateDBToSchema2Hacky step++ freshTestDB step++eitherExc :: MonadBaseControl IO m =>+ (SomeException -> m ()) -> (a -> m ()) -> m a -> m ()+eitherExc left right c = (E.try c) >>= either left right++assertNoException :: String -> TestM () -> TestM ()+assertNoException t c = eitherExc+ (const $ liftIO $ assertFailure ("Exception thrown for: " ++ t))+ (const $ return ()) c++assertException :: String -> TestM () -> TestM ()+assertException t c = eitherExc+ (const $ return ())+ (const $ liftIO $ assertFailure ("No exception thrown for: " ++ t)) c+ -- | A variant of testCaseSteps that works in TestM monad. testCaseSteps' :: TestName -> ConnectionSourceM (LogT IO)- -> ((String -> TestM ()) -> TestM ())- -> TestTree+ -> ((String -> TestM ()) -> TestM ())+ -> TestTree testCaseSteps' testName connSource f = testCaseSteps testName $ \step' -> do let step s = liftIO $ step' s@@ -730,6 +764,7 @@ in testGroup "DB tests" [ migrationTest1 connSource , migrationTest2 connSource+ , migrationTest3 connSource ] where ings =