fix(migration): ignore superfluous migration entries gracefully

src/Model/Migration.hs

@@ -34,17 +34,17 @@ import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorag
 -- import qualified Control.Monad.State.Class as State
 
 
--- _manualMigration :: Fold (Legacy.MigrationVersion, Legacy.Version) ManualMigration
+-- _manualMigration :: Fold (Legacy.Migration Version, Legacy.Version) ManualMigration
 -- _manualMigration = folding $ \case
 --   ([Legacy.migrationVersion|initial|], [Legacy.version|0.0.0|])  -> Just Migration20180813SimplifyUserTheme
 --   ([Legacy.migrationVersion|44.0.0|],  [Legacy.version|45.0.0|]) -> Just Migration20201119RoomTypes
 --   _other -> Nothing
 
-
+-- AppliedMigrationMigration changed vom ManualMigration to Text (via PathPiece) so that removed extra migrations within DB are harmless (before achieved through where-clause)
 share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
   [persistLowerCase|
     AppliedMigration json
-      migration ManualMigration
+      migration Text
       time UTCTime
       Primary migration
       deriving Show Eq Ord
@@ -69,8 +69,9 @@ migrateAll = do
 
   missingMigrations <- getMissingMigrations
   let
-    doCustomMigration acc appliedMigrationMigration migration = acc <* do
-      $logInfoS "Migration" $ toPathPiece appliedMigrationMigration
+    doCustomMigration acc manualMigration migration = acc <* do
+      let appliedMigrationMigration = toPathPiece manualMigration
+      $logInfoS "Migration" appliedMigrationMigration
       appliedMigrationTime <- liftIO getCurrentTime
       _ <- migration
       insert AppliedMigration{..}
@@ -142,7 +143,9 @@ getMissingMigrations = do
   $logDebugS "Migration" "Retrieve applied migrations"
   appliedMigrations <- fmap (map E.unValue) . E.select . E.from $ \appliedMigration -> do    
     return $ appliedMigration E.^. AppliedMigrationMigration
-  return $ customMigrations `Map.withoutKeys` Set.fromList appliedMigrations
+  let migNotDone m _ = toPathPiece m `Set.notMember` Set.fromList appliedMigrations
+  return $ Map.filterWithKey migNotDone customMigrations
+    
 
 getMigrationTime :: ( MonadIO m
                     , BaseBackend backend ~ SqlBackend
@@ -150,4 +153,4 @@ getMigrationTime :: ( MonadIO m
                     )
                  => ManualMigration
                  -> ReaderT backend m (Maybe UTCTime)
-getMigrationTime = fmap (fmap appliedMigrationTime) . get . AppliedMigrationKey
+getMigrationTime = fmap (fmap appliedMigrationTime) . get . AppliedMigrationKey . toPathPiece