Merge pull request #201 from fpco/master

Merge to production

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

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

Handler/MirrorStatus.hs

@@ -0,0 +1,173 @@
+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
+        -- Ignore updates in the past hour, to give the mirrors a
+        -- chance to process them.
+        now <- getCurrentTime
+        let oneHourAgo = 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")
+            , ("commercialhaskell", "all-cabal-metadata", "master")
+            ]
+        tarballMods <- mapM getLastModifiedHTTP
+            [ "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 ++ otherMods
+            biggestDiff = Prelude.maximum $ map
+                (\(_, other) -> diffUTCTime hackageTime 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|
+                    <h1>Mirror Status
+                    <table border=1 cellpadding=1>
+                        <tr>
+                            <th>Name
+                            <th>Last updated
+                            <th>Lag
+                        $forall (name, date) <- allMods
+                            <tr>
+                                <td>#{name}
+                                <td>#{tshow date}
+                                <td>#{showLag (diffUTCTime hackageTime date)}
+                    $if biggestDiff > 0
+                        <p>
+                            Biggest lag: #{showLag biggestDiff}
+                    $if isTooOld
+                        <p style="color:red;font-size:300%">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 :: UTCTime -- ^ latest time to continue
+                 -> IO (Maybe UTCTime)
+getHackageRecent latestTime =
+    httpSink "https://hackage.haskell.org/packages/recent" sink
+  where
+    sink _ = parseBytes def
+         =$= concatMapC getDate
+         =$= filterC (<= latestTime)
+         =$= headC
+
+    getDate :: Event -> Maybe UTCTime
+    getDate (EventContent (ContentText t)) = parseTimeM
+        True
+        defaultTimeLocale
+        "%a %b %_d %H:%M:%S UTC %Y"
+        (unpack t)
+    getDate _ = Nothing

config/routes

@@ -50,3 +50,5 @@
 
 /stack DownloadStackListR GET
 /stack/#Text DownloadStackR GET
+
+/status/mirror MirrorStatusR GET

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-5.15
+resolver: lts-6.17
 packages:
 - .
 - location:

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
@@ -86,7 +87,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 +109,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 +178,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                      >= 1.3         &&   < 1.5
-                  , amazonka-core                 >= 1.3         &&   < 1.4
+                  , amazonka-core                 >= 1.3         &&   < 1.5
-                  , amazonka-s3                   >= 1.3         &&   < 1.4
+                  , amazonka-s3                   >= 1.3         &&   < 1.5
                   , lens                          >= 4.13        &&   < 4.14
                   , file-embed
 

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;