diff --git a/hpqtypes-extras.cabal b/hpqtypes-extras.cabal --- a/hpqtypes-extras.cabal +++ b/hpqtypes-extras.cabal @@ -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, 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 @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 =