diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 34626fd7d..42bd22236 100644 --- a/src/Model/Migration.hs +++ b/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