haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-02-16 12:55:47 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Better Hackage revision delaying

Browse Source
This commit is contained in:
Michael Snoyman 2016-09-20 12:50:50 +03:00
parent 9c90dd1f7d
commit e53b6f50b2
1 changed files with 18 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
Handler/MirrorStatus.hs
View File

@ -23,14 +23,18 @@ mkUpdateMirrorStatus = mkAutoUpdate defaultUpdateSettings
} }
where where
go = do go = do
hackageTime <- getHackageRecent -- Ignore updates in the past hour, to give the mirrors a
-- chance to process them.
now <- getCurrentTime now <- getCurrentTime
let oneHourAgo = addUTCTime (negate $ 60 * 60) now
-- Allow for a grace period between an upload on Hackage and mhackageTime <- getHackageRecent oneHourAgo
-- mirroring, by taking the minimum value between the most
-- recent Hackage update and one hour ago
let delayedTime = min hackageTime $ addUTCTime (negate $ 60 * 60) now
case mhackageTime of
Nothing -> return (status500, "No Hackage time found, could just be a lot of recent uploads")
Just hackageTime -> goHT hackageTime
goHT hackageTime = do
gitMods <- mapM (\(x, y, z) -> getLastModifiedGit x y z) gitMods <- mapM (\(x, y, z) -> getLastModifiedGit x y z)
[ ("commercialhaskell", "all-cabal-files", "current-hackage") [ ("commercialhaskell", "all-cabal-files", "current-hackage")
, ("commercialhaskell", "all-cabal-hashes", "current-hackage") , ("commercialhaskell", "all-cabal-hashes", "current-hackage")
@ -43,7 +47,7 @@ mkUpdateMirrorStatus = mkAutoUpdate defaultUpdateSettings
let nonHackageMods = gitMods ++ tarballMods let nonHackageMods = gitMods ++ tarballMods
allMods = ("Hackage", hackageTime) : nonHackageMods allMods = ("Hackage", hackageTime) : nonHackageMods
biggestDiff = Prelude.maximum $ map biggestDiff = Prelude.maximum $ map
(\(_, other) -> diffUTCTime delayedTime other) (\(_, other) -> diffUTCTime hackageTime other)
nonHackageMods nonHackageMods
showLag x = showLag x =
case compare x 0 of case compare x 0 of
@ -68,7 +72,6 @@ mkUpdateMirrorStatus = mkAutoUpdate defaultUpdateSettings
setTitle "Mirror Status" setTitle "Mirror Status"
[whamlet| [whamlet|
<h1>Mirror Status <h1>Mirror Status
<p>Comparing against delayed update time of: #{tshow delayedTime}
<table border=1 cellpadding=1> <table border=1 cellpadding=1>
<tr> <tr>
<th>Name <th>Name
@ -78,7 +81,7 @@ mkUpdateMirrorStatus = mkAutoUpdate defaultUpdateSettings
<tr> <tr>
<td>#{name} <td>#{name}
<td>#{tshow date} <td>#{tshow date}
<td>#{showLag (diffUTCTime delayedTime date)} <td>#{showLag (diffUTCTime hackageTime date)}
$if biggestDiff > 0 $if biggestDiff > 0
<p> <p>
Biggest lag: #{showLag biggestDiff} Biggest lag: #{showLag biggestDiff}
@ -147,12 +150,15 @@ textJ :: MonadThrow m => Value -> m Text
textJ (String t) = return t textJ (String t) = return t
textJ v = error $ "Invalid value for textJ: " ++ show v textJ v = error $ "Invalid value for textJ: " ++ show v
getHackageRecent :: IO UTCTime getHackageRecent :: UTCTime -- ^ latest time to continue
getHackageRecent = -> IO (Maybe UTCTime)
getHackageRecent latestTime =
httpSink "https://hackage.haskell.org/packages/recent" sink httpSink "https://hackage.haskell.org/packages/recent" sink
where where
sink _ = parseBytes def =$= concatMapC getDate =$= sink _ = parseBytes def
(headC >>= maybe (error "No date found on Hackage recents") return) =$= concatMapC getDate
=$= filterC (<= latestTime)
=$= headC
getDate :: Event -> Maybe UTCTime getDate :: Event -> Maybe UTCTime
getDate (EventContent (ContentText t)) = parseTimeM getDate (EventContent (ContentText t)) = parseTimeM