fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(migration): ignore superfluous migration entries gracefully

Browse Source
This commit is contained in:
Steffen Jost 2023-12-14 11:11:00 +01:00
parent a4b2af7f15
commit 1d48b627f6
1 changed files with 10 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
src/Model/Migration.hs
View File

@ -34,17 +34,17 @@ import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorag
-- import qualified Control.Monad.State.Class as State -- 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 -- _manualMigration = folding $ \case
-- ([Legacy.migrationVersion|initial|], [Legacy.version|0.0.0|]) -> Just Migration20180813SimplifyUserTheme -- ([Legacy.migrationVersion|initial|], [Legacy.version|0.0.0|]) -> Just Migration20180813SimplifyUserTheme
-- ([Legacy.migrationVersion|44.0.0|], [Legacy.version|45.0.0|]) -> Just Migration20201119RoomTypes -- ([Legacy.migrationVersion|44.0.0|], [Legacy.version|45.0.0|]) -> Just Migration20201119RoomTypes
-- _other -> Nothing -- _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"] share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
[persistLowerCase| [persistLowerCase|
AppliedMigration json AppliedMigration json
migration ManualMigration migration Text
time UTCTime time UTCTime
Primary migration Primary migration
deriving Show Eq Ord deriving Show Eq Ord
@ -69,8 +69,9 @@ migrateAll = do
missingMigrations <- getMissingMigrations missingMigrations <- getMissingMigrations
let let
doCustomMigration acc appliedMigrationMigration migration = acc <* do doCustomMigration acc manualMigration migration = acc <* do
$logInfoS "Migration" $ toPathPiece appliedMigrationMigration let appliedMigrationMigration = toPathPiece manualMigration
$logInfoS "Migration" appliedMigrationMigration
appliedMigrationTime <- liftIO getCurrentTime appliedMigrationTime <- liftIO getCurrentTime
_ <- migration _ <- migration
insert AppliedMigration{..} insert AppliedMigration{..}
@ -142,7 +143,9 @@ getMissingMigrations = do
$logDebugS "Migration" "Retrieve applied migrations" $logDebugS "Migration" "Retrieve applied migrations"
appliedMigrations <- fmap (map E.unValue) . E.select . E.from $ \appliedMigration -> do appliedMigrations <- fmap (map E.unValue) . E.select . E.from $ \appliedMigration -> do
return $ appliedMigration E.^. AppliedMigrationMigration 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 getMigrationTime :: ( MonadIO m
, BaseBackend backend ~ SqlBackend , BaseBackend backend ~ SqlBackend
@ -150,4 +153,4 @@ getMigrationTime :: ( MonadIO m
) )
=> ManualMigration => ManualMigration
-> ReaderT backend m (Maybe UTCTime) -> ReaderT backend m (Maybe UTCTime)
getMigrationTime = fmap (fmap appliedMigrationTime) . get . AppliedMigrationKey getMigrationTime = fmap (fmap appliedMigrationTime) . get . AppliedMigrationKey . toPathPiece