Merge pull request #18 from scrive/fix-drop-table-migration-issue

Fix an issue where unnecessary migrations were run sometimes

src/Database/PostgreSQL/PQTypes/Checks.hs

@@ -24,6 +24,7 @@ import Data.Ord (comparing)
 import qualified Data.String
 import Data.Text (Text)
 import Database.PostgreSQL.PQTypes hiding (def)
+import GHC.Stack (HasCallStack)
 import Log
 import Prelude
 import TextShow
@@ -488,7 +489,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do
   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)
@@ -652,13 +653,29 @@ checkDBConsistency options domains tablesWithVersions migrations = do
           -- 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 ()

test/Main.hs

@@ -6,6 +6,7 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Control
 
 import Data.Monoid
+import Prelude
 import Data.Int
 import qualified Data.Text as T
 import Data.Typeable
@@ -688,11 +689,9 @@ freshTestDB step = do
   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
@@ -709,6 +708,14 @@ migrationTest1 connSource =
   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'
@@ -726,18 +733,18 @@ migrationTest2 connSource =
   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)"
   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'"
 
@@ -751,8 +758,8 @@ migrationTest2 connSource =
           \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
@@ -792,12 +799,27 @@ migrationTest3 connSource =
   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
@@ -834,6 +856,7 @@ main = do
     testGroup "DB tests" [ migrationTest1 connSource
                          , migrationTest2 connSource
                          , migrationTest3 connSource
+                         , migrationTest4 connSource
                          ]
   where
     ings =