mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-11 19:58:28 +01:00
Refactor decideOnSnapshotUpdate for understanding
Putting this in a separate commit since I'm actually refactoring code rather than just changing names.
This commit is contained in:
parent
935a5012fe
commit
6bf160f210
@ -515,39 +515,52 @@ sourceSnapshots = do
|
|||||||
return Nothing
|
return Nothing
|
||||||
|
|
||||||
|
|
||||||
|
data DecisionResult a e = NothingToDo | NoSnapshotFile | NeedsUpdate a e | DoesntExist e
|
||||||
|
|
||||||
-- | Creates a new `Snapshot` if it is not yet present in the database and decides if update
|
-- | Creates a new `Snapshot` if it is not yet present in the database and decides if update
|
||||||
-- is necessary when it already exists.
|
-- is necessary when it already exists.
|
||||||
|
--
|
||||||
|
-- TODO: Silently ignoring snapshots where the getter returns Nothing seems like
|
||||||
|
-- a potential problem.
|
||||||
decideOnSnapshotUpdate :: SnapshotFileInfo -> RIO StackageCron (Maybe (SnapshotId, SnapshotFile))
|
decideOnSnapshotUpdate :: SnapshotFileInfo -> RIO StackageCron (Maybe (SnapshotId, SnapshotFile))
|
||||||
decideOnSnapshotUpdate SnapshotFileInfo {sfiSnapName, sfiUpdatedOn, sfiSnapshotFileGetter} = do
|
decideOnSnapshotUpdate SnapshotFileInfo {sfiSnapName, sfiUpdatedOn, sfiSnapshotFileGetter} = do
|
||||||
forceUpdate <- scForceFullUpdate <$> ask
|
forceUpdate <- scForceFullUpdate <$> ask
|
||||||
let mkLogMsg rest = "Snapshot with name: " <> display sfiSnapName <> " " <> rest
|
let mkLogMsg rest = "Snapshot with name: " <> display sfiSnapName <> " " <> rest
|
||||||
mKeySnapFile <-
|
mKeySnapFile <-
|
||||||
run (getBy (UniqueSnapshot sfiSnapName)) >>= \case
|
run (getBy (UniqueSnapshot sfiSnapName)) >>= \case
|
||||||
|
-- exists, up to date, no force-updated requested; nothing to do
|
||||||
Just (Entity _key snap)
|
Just (Entity _key snap)
|
||||||
| snapshotUpdatedOn snap == Just sfiUpdatedOn && not forceUpdate -> do
|
| snapshotUpdatedOn snap == Just sfiUpdatedOn && not forceUpdate -> do
|
||||||
logInfo $ mkLogMsg "already exists and is up to date."
|
logInfo $ mkLogMsg "already exists and is up to date."
|
||||||
return Nothing
|
return NothingToDo
|
||||||
|
-- exists but updatedOn was not previously set.
|
||||||
Just entity@(Entity _key snap)
|
Just entity@(Entity _key snap)
|
||||||
| Nothing <- snapshotUpdatedOn snap -> do
|
| Nothing <- snapshotUpdatedOn snap -> do
|
||||||
logWarn $ mkLogMsg "did not finish updating last time."
|
logWarn $ mkLogMsg "did not finish updating last time."
|
||||||
fmap (Just entity, ) <$> sfiSnapshotFileGetter
|
maybe NoSnapshotFile (NeedsUpdate entity) <$> sfiSnapshotFileGetter
|
||||||
|
-- exists, but updatedOn does not match or force-update was requested.
|
||||||
Just entity -> do
|
Just entity -> do
|
||||||
unless forceUpdate $ logWarn $ mkLogMsg "was updated, applying new patch."
|
unless forceUpdate $ logWarn $ mkLogMsg "was updated, applying new patch."
|
||||||
fmap (Just entity, ) <$> sfiSnapshotFileGetter
|
maybe NoSnapshotFile (NeedsUpdate entity) <$> sfiSnapshotFileGetter
|
||||||
Nothing -> fmap (Nothing, ) <$> sfiSnapshotFileGetter
|
-- does not exist
|
||||||
|
Nothing -> maybe NoSnapshotFile DoesntExist <$> sfiSnapshotFileGetter
|
||||||
-- Add new snapshot to the database, when necessary
|
-- Add new snapshot to the database, when necessary
|
||||||
case mKeySnapFile of
|
case mKeySnapFile of
|
||||||
Just (Just (Entity snapKey snap), sf@SnapshotFile {sfCompiler, sfPublishDate})
|
NothingToDo -> return Nothing
|
||||||
|
NoSnapshotFile -> return Nothing
|
||||||
|
NeedsUpdate (Entity oldSnapKey oldSnap) sf@SnapshotFile {sfCompiler, sfPublishDate}
|
||||||
| Just publishDate <- sfPublishDate -> do
|
| Just publishDate <- sfPublishDate -> do
|
||||||
let updatedSnap =
|
let updatedSnap =
|
||||||
Snapshot sfiSnapName sfCompiler publishDate (snapshotUpdatedOn snap)
|
Snapshot sfiSnapName sfCompiler publishDate (snapshotUpdatedOn oldSnap)
|
||||||
run $ replace snapKey updatedSnap
|
run $ replace oldSnapKey updatedSnap
|
||||||
pure $ Just (snapKey, sf)
|
pure $ Just (oldSnapKey, sf)
|
||||||
Just (Nothing, sf@SnapshotFile {sfCompiler, sfPublishDate})
|
| otherwise -> return Nothing
|
||||||
|
|
||||||
|
DoesntExist sf@SnapshotFile {sfCompiler, sfPublishDate}
|
||||||
| Just publishDate <- sfPublishDate ->
|
| Just publishDate <- sfPublishDate ->
|
||||||
fmap (, sf) <$>
|
fmap (, sf) <$>
|
||||||
run (insertUnique (Snapshot sfiSnapName sfCompiler publishDate Nothing))
|
run (insertUnique (Snapshot sfiSnapName sfCompiler publishDate Nothing))
|
||||||
_ -> return Nothing
|
| otherwise -> return Nothing
|
||||||
|
|
||||||
type CorePackageGetter
|
type CorePackageGetter
|
||||||
= RIO StackageCron ( Either CabalFileIds (Entity Tree)
|
= RIO StackageCron ( Either CabalFileIds (Entity Tree)
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user