From 0c664efe345e487bdb3b9e2684d929ab4205c920 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 20 Sep 2016 08:01:37 +0300 Subject: [PATCH 1/5] LTS bump --- stack.yaml | 2 +- stackage-server.cabal | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/stack.yaml b/stack.yaml index b7bf15a..86f2b42 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-5.15 +resolver: lts-6.17 packages: - . - location: diff --git a/stackage-server.cabal b/stackage-server.cabal index 2998e60..37b5812 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -86,7 +86,7 @@ library build-depends: base >= 4.8 && < 4.9 - , aeson >= 0.9 && < 0.10 + , aeson >= 0.9 && < 0.12 , aeson-extra >= 0.3 && < 0.4 , aws >= 0.13 && < 0.14 , barrier >= 0.1 && < 0.2 @@ -108,7 +108,7 @@ library , fast-logger >= 2.4 && < 2.5 , foreign-store >= 0.2 && < 0.3 , ghc-prim >= 0.4 && < 0.5 - , hjsmin >= 0.1 && < 0.2 + , hjsmin >= 0.1 && < 0.3 , html-conduit >= 1.2 && < 1.3 , http-conduit >= 2.1.8 && < 2.2 , monad-control >= 1.0 && < 1.1 @@ -177,9 +177,9 @@ library , filepath >= 1.4 && < 1.5 , http-client >= 0.4 && < 0.5 , http-types >= 0.9 && < 0.10 - , amazonka >= 1.3 && < 1.4 - , amazonka-core >= 1.3 && < 1.4 - , amazonka-s3 >= 1.3 && < 1.4 + , amazonka >= 1.3 && < 1.5 + , amazonka-core >= 1.3 && < 1.5 + , amazonka-s3 >= 1.3 && < 1.5 , lens >= 4.13 && < 4.14 , file-embed From 9c90dd1f7d323fc3a27acd1e1076693a9b7b6764 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 20 Sep 2016 12:40:42 +0300 Subject: [PATCH 2/5] Add a /status/mirror route --- Application.hs | 3 + Foundation.hs | 1 + Handler/MirrorStatus.hs | 163 ++++++++++++++++++++++++++++++++++++++++ config/routes | 2 + stackage-server.cabal | 1 + 5 files changed, 170 insertions(+) create mode 100644 Handler/MirrorStatus.hs 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| +

Mirror Status +

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 From e53b6f50b2599b51caf32526c9b1a3d970c1486b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 20 Sep 2016 12:50:50 +0300 Subject: [PATCH 3/5] Better Hackage revision delaying --- Handler/MirrorStatus.hs | 30 ++++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/Handler/MirrorStatus.hs b/Handler/MirrorStatus.hs index a1de0bb..15b5572 100644 --- a/Handler/MirrorStatus.hs +++ b/Handler/MirrorStatus.hs @@ -23,14 +23,18 @@ mkUpdateMirrorStatus = mkAutoUpdate defaultUpdateSettings } where go = do - hackageTime <- getHackageRecent + -- Ignore updates in the past hour, to give the mirrors a + -- chance to process them. now <- getCurrentTime + let oneHourAgo = addUTCTime (negate $ 60 * 60) now - -- 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 + mhackageTime <- getHackageRecent oneHourAgo + 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) [ ("commercialhaskell", "all-cabal-files", "current-hackage") , ("commercialhaskell", "all-cabal-hashes", "current-hackage") @@ -43,7 +47,7 @@ mkUpdateMirrorStatus = mkAutoUpdate defaultUpdateSettings let nonHackageMods = gitMods ++ tarballMods allMods = ("Hackage", hackageTime) : nonHackageMods biggestDiff = Prelude.maximum $ map - (\(_, other) -> diffUTCTime delayedTime other) + (\(_, other) -> diffUTCTime hackageTime other) nonHackageMods showLag x = case compare x 0 of @@ -68,7 +72,6 @@ mkUpdateMirrorStatus = mkAutoUpdate defaultUpdateSettings setTitle "Mirror Status" [whamlet|

Mirror Status -

Comparing against delayed update time of: #{tshow delayedTime}
Name @@ -78,7 +81,7 @@ mkUpdateMirrorStatus = mkAutoUpdate defaultUpdateSettings
#{name} #{tshow date} - #{showLag (diffUTCTime delayedTime date)} + #{showLag (diffUTCTime hackageTime date)} $if biggestDiff > 0

Biggest lag: #{showLag biggestDiff} @@ -147,12 +150,15 @@ textJ :: MonadThrow m => Value -> m Text textJ (String t) = return t textJ v = error $ "Invalid value for textJ: " ++ show v -getHackageRecent :: IO UTCTime -getHackageRecent = +getHackageRecent :: UTCTime -- ^ latest time to continue + -> IO (Maybe UTCTime) +getHackageRecent latestTime = httpSink "https://hackage.haskell.org/packages/recent" sink where - sink _ = parseBytes def =$= concatMapC getDate =$= - (headC >>= maybe (error "No date found on Hackage recents") return) + sink _ = parseBytes def + =$= concatMapC getDate + =$= filterC (<= latestTime) + =$= headC getDate :: Event -> Maybe UTCTime getDate (EventContent (ContentText t)) = parseTimeM From 7db1e96d9ce6e5ea4af707cb967b20d3f1cd808f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 22 Sep 2016 10:10:54 +0300 Subject: [PATCH 4/5] Add @hvr's mirror --- Handler/MirrorStatus.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/Handler/MirrorStatus.hs b/Handler/MirrorStatus.hs index 15b5572..711ffb6 100644 --- a/Handler/MirrorStatus.hs +++ b/Handler/MirrorStatus.hs @@ -44,8 +44,12 @@ mkUpdateMirrorStatus = mkAutoUpdate defaultUpdateSettings [ "http://hackage.fpcomplete.com/00-index.tar.gz" , "http://hackage.fpcomplete.com/01-index.tar.gz" ] + otherMods <- mapM getLastModifiedHTTP + [ "http://objects-us-west-1.dream.io/hackage-mirror/01-index.tar.gz" + , "http://objects-us-west-1.dream.io/hackage-mirror/timestamp.json" + ] let nonHackageMods = gitMods ++ tarballMods - allMods = ("Hackage", hackageTime) : nonHackageMods + allMods = ("Hackage", hackageTime) : nonHackageMods ++ otherMods biggestDiff = Prelude.maximum $ map (\(_, other) -> diffUTCTime hackageTime other) nonHackageMods From 6c98313d85a92a34ce2dfcd23123af5bd984c1cb Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 23 Sep 2016 11:20:04 +0300 Subject: [PATCH 5/5] Add in monospace fallback for Haddock #199 --- static/haddock/style.css | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/static/haddock/style.css b/static/haddock/style.css index d8ff95f..6dedf47 100644 --- a/static/haddock/style.css +++ b/static/haddock/style.css @@ -616,7 +616,7 @@ a[href] { } .caption { color: #6e618d!important } pre{ background: #f8f8f8; padding: 1em; } -pre, pre * { font-family: "ubuntu mono", "Monaco" !important; font-size: 13px !important; } +pre, pre * { font-family: "ubuntu mono", "Monaco", monospace !important; font-size: 13px !important; } #table-of-contents { background: #f8f8f8; border: 1px solid #eee;