diff --git a/Application.hs b/Application.hs index b4fd26f..97d7b1f 100644 --- a/Application.hs +++ b/Application.hs @@ -55,6 +55,7 @@ import Handler.Download import Handler.OldLinks import Handler.Feed import Handler.DownloadStack +import Handler.MirrorStatus import Network.Wai.Middleware.Prometheus (prometheus) import Prometheus (register) @@ -134,6 +135,8 @@ makeFoundation appSettings = do appHoogleLock <- newMVar () + appMirrorStatus <- mkUpdateMirrorStatus + return App {..} makeLogWare :: App -> IO Middleware diff --git a/Foundation.hs b/Foundation.hs index d46cf04..d4d33ca 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -29,6 +29,7 @@ data App = App , appHoogleLock :: MVar () -- ^ Avoid concurrent Hoogle queries, see -- https://github.com/fpco/stackage-server/issues/172 + , appMirrorStatus :: IO (Status, WidgetT App IO ()) } instance HasHttpManager App where diff --git a/Handler/MirrorStatus.hs b/Handler/MirrorStatus.hs new file mode 100644 index 0000000..a1de0bb --- /dev/null +++ b/Handler/MirrorStatus.hs @@ -0,0 +1,163 @@ +module Handler.MirrorStatus + ( getMirrorStatusR + , mkUpdateMirrorStatus + ) where + +import Import +import Control.AutoUpdate +import Network.HTTP.Simple +import Data.Time (parseTimeM, diffUTCTime, addUTCTime) +import Text.XML.Stream.Parse +import Data.XML.Types (Event (EventContent), Content (ContentText)) +import qualified Prelude + +getMirrorStatusR :: Handler Html +getMirrorStatusR = do + (status, widget) <- getYesod >>= liftIO . appMirrorStatus + defaultLayout widget >>= sendResponseStatus status + +mkUpdateMirrorStatus :: IO (IO (Status, Widget)) +mkUpdateMirrorStatus = mkAutoUpdate defaultUpdateSettings + { updateAction = go + , updateFreq = 1000 * 1000 * 60 + } + where + go = do + hackageTime <- getHackageRecent + now <- getCurrentTime + + -- Allow for a grace period between an upload on Hackage and + -- 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 + + gitMods <- mapM (\(x, y, z) -> getLastModifiedGit x y z) + [ ("commercialhaskell", "all-cabal-files", "current-hackage") + , ("commercialhaskell", "all-cabal-hashes", "current-hackage") + , ("commercialhaskell", "all-cabal-metadata", "master") + ] + tarballMods <- mapM getLastModifiedHTTP + [ "http://hackage.fpcomplete.com/00-index.tar.gz" + , "http://hackage.fpcomplete.com/01-index.tar.gz" + ] + let nonHackageMods = gitMods ++ tarballMods + allMods = ("Hackage", hackageTime) : nonHackageMods + biggestDiff = Prelude.maximum $ map + (\(_, other) -> diffUTCTime delayedTime other) + nonHackageMods + showLag x = + case compare x 0 of + EQ -> "" + LT -> showDiff (abs x) ++ " (mirror newer)" + GT -> showDiff x ++ " (Hackage newer)" + showDiff x = + let (minutes', seconds) = floor x `divMod` (60 :: Int) + (hours, minutes) = minutes' `divMod` 60 + showInt i + | i < 10 = '0' : show i + | otherwise = show i + showSuffix suffix i + | i == 0 = "" + | otherwise = showInt i ++ suffix + in unwords $ filter (not . null) + [ showSuffix "h" hours + , showSuffix "m" minutes + , showSuffix "s" seconds + ] + widget = do + setTitle "Mirror Status" + [whamlet| +
Comparing against delayed update time of: #{tshow delayedTime} +
| Name + | Last updated + | Lag + $forall (name, date) <- allMods + |
|---|---|---|
| #{name} + | #{tshow date} + | #{showLag (diffUTCTime delayedTime date)}
+ $if biggestDiff > 0
+ + Biggest lag: #{showLag biggestDiff} + $if isTooOld + WARNING: Mirrors may be out of sync! + |] + isTooOld = biggestDiff > (60 * 60) + status = if isTooOld then status500 else status200 + return (status, widget) + +getLastModifiedHTTP :: Text -- ^ url + -> IO (Text, UTCTime) +getLastModifiedHTTP url = do + req <- fmap (setRequestMethod "HEAD") $ parseUrlThrow $ unpack url + res <- httpLBS req + case getResponseHeader "last-modified" res of + [x] -> do + date <- parseTimeM + True + defaultTimeLocale + "%a, %_d %b %Y %H:%M:%S %Z" + (unpack $ decodeUtf8 x) + return (url, date) + x -> error $ "invalid last-modified for " ++ show (url, res, x) + +getLastModifiedGit :: Text -- ^ org + -> Text -- ^ repo + -> Text -- ^ ref + -> IO (Text, UTCTime) +getLastModifiedGit org repo ref = do + req <- parseUrlThrow $ unpack url + res <- httpJSON $ addRequestHeader "User-Agent" "Stackage Server" req + dateT <- lookupJ "commit" (getResponseBody res) + >>= lookupJ "author" + >>= lookupJ "date" + >>= textJ + date <- parseTimeM + True + defaultTimeLocale + "%Y-%m-%dT%H:%M:%SZ" + (unpack dateT) + return (concat [org, "/", repo], date) + where + url = concat + [ "https://api.github.com/repos/" + , org + , "/" + , repo + , "/commits/" + , ref + ] + +lookupJ :: MonadThrow m => Text -> Value -> m Value +lookupJ key (Object o) = + case lookup key o of + Nothing -> error $ "Key not found: " ++ show key + Just x -> return x +lookupJ key val = error $ concat + [ "Looking up key " + , show key + , " on non-object " + , show val + ] + +textJ :: MonadThrow m => Value -> m Text +textJ (String t) = return t +textJ v = error $ "Invalid value for textJ: " ++ show v + +getHackageRecent :: IO UTCTime +getHackageRecent = + httpSink "https://hackage.haskell.org/packages/recent" sink + where + sink _ = parseBytes def =$= concatMapC getDate =$= + (headC >>= maybe (error "No date found on Hackage recents") return) + + getDate :: Event -> Maybe UTCTime + getDate (EventContent (ContentText t)) = parseTimeM + True + defaultTimeLocale + "%a %b %_d %H:%M:%S UTC %Y" + (unpack t) + getDate _ = Nothing diff --git a/config/routes b/config/routes index f431a92..7c8fb83 100644 --- a/config/routes +++ b/config/routes @@ -50,3 +50,5 @@ /stack DownloadStackListR GET /stack/#Text DownloadStackR GET + +/status/mirror MirrorStatusR GET \ No newline at end of file diff --git a/stackage-server.cabal b/stackage-server.cabal index 37b5812..fc43d64 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -46,6 +46,7 @@ library Handler.OldLinks Handler.Feed Handler.DownloadStack + Handler.MirrorStatus if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT |