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

fix(migration): don't consider changelog in requiresMigration

Browse Source
This commit is contained in:
Gregor Kleen 2020-10-14 16:24:21 +02:00
parent c8d83aeb93
commit ea95d74cb5
1 changed files with 23 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
src/Model/Migration.hs
View File

@ -110,6 +110,9 @@ migrateAll = do
$logDebugS "Migration" "Persistent automatic migration"
mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAll'
$logDebugS "Migration" "Migrations marked as ‘always safe’"
mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAlwaysSafe
requiresMigration :: forall m.
( MonadLogger m
, MonadResource m
@ -131,6 +134,8 @@ requiresMigration = mapReaderT (exceptT return return) $ do
$logInfoS "Migration" $ intercalate "; " automatic
throwError True
-- Does not consider `migrateAlwaysSafe`
return False
initialMigration :: Migration
@ -172,19 +177,6 @@ migrateManual = do
, ("user_ldap_primary_key", "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)" )
, ("file_content_entry_chunk_hash", "CREATE INDEX file_content_entry_chunk_hash ON \"file_content_entry\" (chunk_hash)" )
]
recordedChangelogItems <- lift . lift $ selectList [ ChangelogItemFirstSeenItem <-. universeF ] []
let missingChangelogItems = Set.toList $ Set.fromList universeF `Set.difference` recordedChangelogItems'
where recordedChangelogItems' = Set.fromList [ changelogItemFirstSeenItem | Entity _ ChangelogItemFirstSeen{..} <- recordedChangelogItems ]
unless (null missingChangelogItems) $ do
now <- iso8601Show . localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
addMigration False $
let sql = [st|INSERT INTO changelog_item_first_seen (item, first_seen) VALUES #{vals}|]
vals = Text.intercalate ", " $ do
item <- missingChangelogItems
return [st|('#{toPathPiece item}', '#{now}')|]
in sql
where
addIndex :: Text -> Sql -> Migration
addIndex ixName ixDef = do
@ -194,6 +186,23 @@ migrateManual = do
_other -> return True
unless alreadyDefined $ addMigration False ixDef
migrateAlwaysSafe :: Migration
-- | Part of `migrateAll` but not checked in `requiresMigration`
migrateAlwaysSafe = do
recordedChangelogItems <- lift . lift $ selectList [ ChangelogItemFirstSeenItem <-. universeF ] []
let missingChangelogItems = Set.toList $ Set.fromList universeF `Set.difference` recordedChangelogItems'
where recordedChangelogItems' = Set.fromList [ changelogItemFirstSeenItem | Entity _ ChangelogItemFirstSeen{..} <- recordedChangelogItems ]
unless (null missingChangelogItems) $ do
now <- iso8601Show . localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
addMigration False $ do
let sql = [st|INSERT INTO changelog_item_first_seen (item, first_seen) VALUES #{vals}|]
vals = Text.intercalate ", " $ do
item <- missingChangelogItems
let itemDay = case Map.lookup item changelogItemDays of
Just d -> iso8601Show d
Nothing -> now
return [st|('#{toPathPiece item}', '#{itemDay}')|]
in sql
{-
Confusion about quotes, from the PostgreSQL Manual:
@ -979,13 +988,7 @@ customMigrations = Map.fromListWith (>>)
|]
)
, ( AppliedMigrationKey [migrationVersion|42.0.0|] [version|43.0.0|]
, unlessM (tableExists "changelog_item_first_seen") $ do
[executeQQ|
CREATE TABLE "changelog_item_first_seen" (PRIMARY KEY ("item"), "item" VARCHAR NOT NULL, "first_seen" DATE NOT NULL);
|]
insertMany_ [ ChangelogItemFirstSeen{..}
| (changelogItemFirstSeenItem, changelogItemFirstSeenFirstSeen) <- Map.toList changelogItemDays
]
, return () -- Unused; used to create and fill `ChangelogItemFirstSeen`
)
]