Merge pull request #181 from fpco/with-metrics

add basic metrics

Application.hs

@@ -56,6 +56,10 @@ import           Handler.OldLinks
 import           Handler.Feed
 import           Handler.DownloadStack
 
+import           Network.Wai.Middleware.Prometheus (prometheus)
+import           Prometheus (register)
+import           Prometheus.Metric.GHC (ghcMetrics)
+
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
 -- comments there for more details.
@@ -72,9 +76,12 @@ makeApplication foundation = do
     appPlain <- toWaiAppPlain foundation
 
     let middleware = forceSSL' (appSettings foundation)
+                   . prometheus def
                    . logWare
                    . defaultMiddlewaresNoLogging
 
+    void (register ghcMetrics)
+
     return (middleware appPlain)
 
 forceSSL' :: AppSettings -> Middleware

Handler/BuildPlan.hs

@@ -7,7 +7,7 @@ import Stackage.BuildPlan
 import Stackage.Database
 
 getBuildPlanR :: SnapName -> Handler TypedContent
-getBuildPlanR slug = do
+getBuildPlanR slug = track "Handler.BuildPlan.getBuildPlanR" $ do
     fullDeps <- (== Just "true") <$> lookupGetParam "full-deps"
     spec <- parseSnapshotSpec $ toPathPiece slug
     let set = setShellCommands simpleCommands

Handler/Download.hs

@@ -13,13 +13,16 @@ import Stackage.Database
 import qualified Data.Text as T
 
 getDownloadR :: Handler Html
-getDownloadR = redirectWith status301 InstallR
+getDownloadR = track "Hoogle.Download.getDownloadR" $
+    redirectWith status301 InstallR
 
 getDownloadSnapshotsJsonR :: Handler Value
-getDownloadSnapshotsJsonR = getDownloadLtsSnapshotsJsonR
+getDownloadSnapshotsJsonR = track "Hoogle.Download.getDownloadSnapshotsJsonR"
+    getDownloadLtsSnapshotsJsonR
 
 getDownloadLtsSnapshotsJsonR :: Handler Value
-getDownloadLtsSnapshotsJsonR = snapshotsJSON
+getDownloadLtsSnapshotsJsonR = track "Hoogle.Download.getDownloadLtsSnapshotsJsonR"
+    snapshotsJSON
 
 -- Print the ghc major version for the given snapshot.
 ghcMajorVersionText :: Snapshot -> Text
@@ -30,12 +33,12 @@ ghcMajorVersionText =
     getMajorVersion = intercalate "." . take 2 . T.splitOn "."
 
 getGhcMajorVersionR :: SnapName -> Handler Text
-getGhcMajorVersionR name = do
+getGhcMajorVersionR name = track "Hoogle.Download.getGhcMajorVersionR" $ do
     snapshot <- lookupSnapshot name >>= maybe notFound return
     return $ ghcMajorVersionText $ entityVal snapshot
 
 getDownloadGhcLinksR :: SupportedArch -> Text -> Handler TypedContent
-getDownloadGhcLinksR arch fileName = do
+getDownloadGhcLinksR arch fileName = track "Hoogle.Download.getDownloadGhcLinksR" $ do
   ver <- maybe notFound return
        $ stripPrefix "ghc-"
          >=> stripSuffix "-links.yaml"

Handler/DownloadStack.hs

@@ -12,14 +12,14 @@ import Data.Conduit.Attoparsec (sinkParser)
 import Data.Monoid (First (..))
 
 getDownloadStackListR :: Handler Html
-getDownloadStackListR = do
+getDownloadStackListR = track "Handler.DownloadStack.getDownloadStackListR" $ do
     releases <- getYesod >>= fmap wcStackReleases . liftIO . grContent . appWebsiteContent
     defaultLayout $ do
         setTitle "Download Stack"
         $(widgetFile "download-stack-list")
 
 getDownloadStackR :: Text -> Handler ()
-getDownloadStackR pattern = do
+getDownloadStackR pattern = track "Handler.DownloadStack.getDownloadStackR" $ do
     matcher <- getYesod >>= liftIO . appLatestStackMatcher
     maybe notFound redirect $ matcher pattern
 

Handler/Feed.hs

@@ -10,10 +10,10 @@ import Stackage.Snapshot.Diff
 import Text.Blaze (text)
 
 getFeedR :: Handler TypedContent
-getFeedR = getBranchFeed Nothing
+getFeedR = track "Handler.Feed.getBranchFeedR" $ getBranchFeed Nothing
 
 getBranchFeedR :: SnapshotBranch -> Handler TypedContent
-getBranchFeedR = getBranchFeed . Just
+getBranchFeedR = track "Handler.Feed.getBranchFeedR" . getBranchFeed . Just
 
 getBranchFeed :: Maybe SnapshotBranch -> Handler TypedContent
 getBranchFeed mBranch = mkFeed mBranch =<< getSnapshots mBranch 20 0

Handler/Haddock.hs

@@ -21,7 +21,7 @@ shouldRedirect = False
 getHaddockR :: SnapName -> [Text] -> Handler TypedContent
 getHaddockR slug rest
   | shouldRedirect = redirect $ makeURL slug rest
-  | final:_ <- reverse rest, ".html" `isSuffixOf` final = do
+  | final:_ <- reverse rest, ".html" `isSuffixOf` final = track "Handler.Haddock.getHaddockR" $ do
       render <- getUrlRender
 
       let stylesheet = render' $ StaticR haddock_style_css
@@ -100,6 +100,6 @@ nav =
                 close = [EventEndElement name]
 
 getHaddockBackupR :: [Text] -> Handler ()
-getHaddockBackupR rest = redirect $ concat
+getHaddockBackupR rest = track "Handler.Haddock.getHaddockBackupR" $ redirect $ concat
     $ "https://s3.amazonaws.com/haddock.stackage.org"
     : map (cons '/') rest

Handler/Hoogle.hs

@@ -12,12 +12,12 @@ import Stackage.Database
 import qualified Stackage.Database.Cron as Cron
 
 getHoogleDB :: SnapName -> Handler (Maybe FilePath)
-getHoogleDB name = do
+getHoogleDB name = track "Handler.Hoogle.getHoogleDB" $ do
     app <- getYesod
     liftIO $ Cron.getHoogleDB True (appHttpManager app) name
 
 getHoogleR :: SnapName -> Handler Html
-getHoogleR name = do
+getHoogleR name = track "Handler.Hoogle.getHoogleR" $ do
     Entity _ snapshot <- lookupSnapshot name >>= maybe notFound return
     mquery <- lookupGetParam "q"
     mpage <- lookupGetParam "page"
@@ -60,21 +60,22 @@ getHoogleR name = do
         $(widgetFile "hoogle")
 
 getHoogleDatabaseR :: SnapName -> Handler Html
-getHoogleDatabaseR name = do
+getHoogleDatabaseR name = track "Handler.Hoogle.getHoogleDatabaseR" $ do
     mdatabasePath <- getHoogleDB name
     case mdatabasePath of
         Nothing -> hoogleDatabaseNotAvailableFor name
         Just path -> sendFile "application/octet-stream" path
 
 hoogleDatabaseNotAvailableFor :: SnapName -> Handler a
-hoogleDatabaseNotAvailableFor name = (>>= sendResponse) $ defaultLayout $ do
-    setTitle "Hoogle database not available"
-    [whamlet|
-        <div .container>
-            <p>The given Hoogle database is not available.
-            <p>
-                <a href=@{SnapshotR name StackageHomeR}>Return to snapshot homepage
-    |]
+hoogleDatabaseNotAvailableFor name = track "Handler.Hoogle.hoogleDatabaseNotAvailableFor" $ do
+    (>>= sendResponse) $ defaultLayout $ do
+        setTitle "Hoogle database not available"
+        [whamlet|
+            <div .container>
+                <p>The given Hoogle database is not available.
+                <p>
+                    <a href=@{SnapshotR name StackageHomeR}>Return to snapshot homepage
+        |]
 
 getPageCount :: Int -> Int
 getPageCount totalCount = 1 + div totalCount perPage
@@ -118,11 +119,12 @@ instance NFData HoogleResult where rnf = genericRnf
 instance NFData PackageLink where rnf = genericRnf
 instance NFData ModuleLink where rnf = genericRnf
 
-runHoogleQuery :: Monad m
+runHoogleQuery :: MonadIO m
                => m Hoogle.Database
                -> HoogleQueryInput
                -> m HoogleQueryOutput
 runHoogleQuery heDatabase HoogleQueryInput {..} =
+    track "Handler.Hoogle.runHoogleQuery" $
     runQuery $ Hoogle.parseQuery Hoogle.Haskell query
   where
     query = unpack hqiQueryInput

Handler/OldLinks.hs

@@ -27,7 +27,7 @@ redirectWithQueryText url = do
     redirect $ url ++ decodeUtf8 (rawQueryString req)
 
 getOldSnapshotBranchR :: SnapshotBranch -> [Text] -> Handler ()
-getOldSnapshotBranchR LtsBranch pieces = do
+getOldSnapshotBranchR LtsBranch pieces = track "Handler.OldLinks.getOldSnapshotBranchR@LtsBranch" $ do
     (x, y, pieces') <- case pieces of
         t:ts | Just suffix <- parseLtsSuffix t -> do
             (x, y) <- case suffix of
@@ -42,12 +42,12 @@ getOldSnapshotBranchR LtsBranch pieces = do
     let name = concat ["lts-", tshow x, ".", tshow y]
     redirectWithQueryText $ concatMap (cons '/') $ name : pieces'
 
-getOldSnapshotBranchR (LtsMajorBranch x) pieces = do
+getOldSnapshotBranchR (LtsMajorBranch x) pieces = track "Handler.OldLinks.getOldSnapshotBranchR@LtsMajorBranch" $ do
     y <- newestLTSMajor x >>= maybe notFound return
     let name = concat ["lts-", tshow x, ".", tshow y]
     redirectWithQueryText $ concatMap (cons '/') $ name : pieces
 
-getOldSnapshotBranchR NightlyBranch pieces = do
+getOldSnapshotBranchR NightlyBranch pieces = track "Handler.OldLinks.getOldSnapshotBranchR@NightlyBranch" $ do
     (day, pieces') <- case pieces of
         t:ts | Just day <- fromPathPiece t -> return (day, ts)
         _ -> do
@@ -57,7 +57,7 @@ getOldSnapshotBranchR NightlyBranch pieces = do
     redirectWithQueryText $ concatMap (cons '/') $ name : pieces'
 
 getOldSnapshotR :: Text -> [Text] -> Handler ()
-getOldSnapshotR t ts =
+getOldSnapshotR t ts = track "Handler.OldLinks.getOldSnapshotR" $
     case fromPathPiece t :: Maybe SnapName of
         Just _ -> redirectWithQueryText $ concatMap (cons '/') $ t : ts
         Nothing -> notFound

Handler/Package.hs

@@ -24,10 +24,10 @@ import           Stackage.Database
 
 -- | Page metadata package.
 getPackageR :: PackageName -> Handler Html
-getPackageR = packagePage Nothing
+getPackageR = track "Handler.Package.getPackageR" . packagePage Nothing
 
 getPackageBadgeR :: PackageName -> SnapshotBranch -> Handler TypedContent
-getPackageBadgeR pname branch = do
+getPackageBadgeR pname branch = track "Handler.Package.getPackageBadgeR" $ do
     cacheSeconds (3 * 60 * 60)
     snapName     <- maybe notFound pure =<< newestSnapshot branch
     Entity sid _ <- maybe notFound pure =<< lookupSnapshot snapName
@@ -60,7 +60,7 @@ renderStackageBadge style mLabel snapName = \case
 packagePage :: Maybe (SnapName, Version)
             -> PackageName
             -> Handler Html
-packagePage mversion pname = do
+packagePage mversion pname = track "Handler.Package.packagePage" $ do
     let pname' = toPathPiece pname
     (deprecated, inFavourOf) <- getDeprecated pname'
     latests <- getLatests pname'
@@ -221,7 +221,7 @@ renderEmail :: EmailAddress -> Text
 renderEmail = T.decodeUtf8 . toByteString
 
 getPackageSnapshotsR :: PackageName -> Handler Html
-getPackageSnapshotsR pn =
+getPackageSnapshotsR pn = track "Handler.Package.getPackageSnapshotsR" $
   do snapshots <- getSnapshotsForPackage $ toPathPiece pn
      defaultLayout
        (do setTitle ("Packages for " >> toHtml pn)

Handler/PackageList.hs

@@ -6,8 +6,9 @@ import Stackage.Database
 
 -- FIXME maybe just redirect to the LTS or nightly package list
 getPackageListR :: Handler Html
-getPackageListR = defaultLayout $ do
-    setTitle "Package list"
-    packages <- getAllPackages
-    $(widgetFile "package-list")
+getPackageListR = track "Handler.PackageList.getPackageListR" $ do
+    defaultLayout $ do
+        setTitle "Package list"
+        packages <- getAllPackages
+        $(widgetFile "package-list")
   where strip x = fromMaybe x (stripSuffix "." x)

Handler/Sitemap.hs

@@ -8,7 +8,7 @@ import Yesod.Sitemap
 type Sitemap = forall m. Monad m => Producer m (SitemapUrl (Route App))
 
 getSitemapR :: Handler TypedContent
-getSitemapR = sitemap $ do
+getSitemapR = track "Handler.Sitemap.getSitemapR" $ sitemap $ do
     priority 1.0 $ HomeR
 
     priority 0.9 $ OldSnapshotBranchR LtsBranch []

Handler/Snapshots.hs

@@ -19,7 +19,7 @@ snapshotsPerPage = 50
 -- functions. You can spread them across multiple files if you are so
 -- inclined, or create a single monolithic file.
 getAllSnapshotsR :: Handler Html
-getAllSnapshotsR = do
+getAllSnapshotsR = track "Handler.Snapshots.getAllSnapshotsR" $ do
     now' <- liftIO getCurrentTime
     currentPageMay <- lookupGetParam "page"
     let currentPage :: Int

Handler/StackageHome.hs

@@ -14,7 +14,7 @@ import Stackage.Database.Types (isLts)
 import Stackage.Snapshot.Diff
 
 getStackageHomeR :: SnapName -> Handler TypedContent
-getStackageHomeR name = do
+getStackageHomeR name = track "Handler.StackageHome.getStackageHomeR" $ do
     Entity sid snapshot <- lookupSnapshot name >>= maybe notFound return
     previousSnapName <- fromMaybe name . map snd <$> snapshotBefore (snapshotName snapshot)
     let hoogleForm =
@@ -43,7 +43,7 @@ instance ToJSON SnapshotInfo where
                                    ]
 
 getStackageDiffR :: SnapName -> SnapName -> Handler TypedContent
-getStackageDiffR name1 name2 = do
+getStackageDiffR name1 name2 = track "Handler.StackageHome.getStackageDiffR" $ do
     Entity sid1 _ <- lookupSnapshot name1 >>= maybe notFound return
     Entity sid2 _ <- lookupSnapshot name2 >>= maybe notFound return
     (map (snapshotName . entityVal) -> snapNames) <- getSnapshots Nothing 0 0
@@ -57,7 +57,7 @@ getStackageDiffR name1 name2 = do
         provideRep $ pure $ toJSON $ WithSnapshotNames name1 name2 snapDiff
 
 getStackageCabalConfigR :: SnapName -> Handler TypedContent
-getStackageCabalConfigR name = do
+getStackageCabalConfigR name = track "Handler.StackageHome.getStackageCabalConfigR" $ do
     Entity sid _ <- lookupSnapshot name >>= maybe notFound return
     render <- getUrlRender
 
@@ -139,10 +139,11 @@ yearMonthDay :: FormatTime t => t -> String
 yearMonthDay = formatTime defaultTimeLocale "%Y-%m-%d"
 
 getSnapshotPackagesR :: SnapName -> Handler () -- FIXME move to OldLinks?
-getSnapshotPackagesR name = redirect $ SnapshotR name StackageHomeR
+getSnapshotPackagesR name = track "Handler.StackageHome.getSnapshotPackagesR" $
+    redirect $ SnapshotR name StackageHomeR
 
 getDocsR :: SnapName -> Handler Html
-getDocsR name = do
+getDocsR name = track "Handler.StackageHome.getDocsR" $ do
     Entity sid _ <- lookupSnapshot name >>= maybe notFound return
     mlis <- getSnapshotModules sid
     render <- getUrlRender

Handler/StackageSdist.hs

@@ -7,7 +7,7 @@ import Stackage.Database
 import Handler.Package (packagePage)
 
 getStackageSdistR :: SnapName -> PackageNameVersion -> Handler TypedContent
-getStackageSdistR _ (PNVTarball name version) = do
+getStackageSdistR _ (PNVTarball name version) = track "Handler.StackageSdist.getStackageSdistR" $ do
     redirect $ concat
         -- unfortunately using insecure HTTP for cabal's sake
         [ "http://hackage.fpcomplete.com/package/"
@@ -16,10 +16,10 @@ getStackageSdistR _ (PNVTarball name version) = do
         , toPathPiece version
         , ".tar.gz"
         ]
-getStackageSdistR sname (PNVName pname) = do
+getStackageSdistR sname (PNVName pname) = track "Handler.StackageSdist.getStackageSdistR" $ do
     version <- versionHelper sname pname
     redirect $ SnapshotR sname $ StackageSdistR $ PNVNameVersion pname version
-getStackageSdistR sname (PNVNameVersion pname version) = do
+getStackageSdistR sname (PNVNameVersion pname version) = track "Handler.StackageSdist.getStackageSdistR" $ do
     version' <- versionHelper sname pname
     if version == version'
         then packagePage (Just (sname, version)) pname >>= sendResponse

Handler/System.hs

@@ -4,4 +4,5 @@ import Import
 import System.Process (readProcess)
 
 getSystemR :: Handler String
-getSystemR = liftIO $ readProcess "df" ["-ih"] ""
+getSystemR = track "Handler.System.getSystemR" $
+    liftIO $ readProcess "df" ["-ih"] ""

Import.hs

@@ -10,6 +10,8 @@ import Types as Import
 import Yesod.Auth as Import
 import Data.WebsiteContent as Import (WebsiteContent (..))
 import Data.Text.Read (decimal)
+import Data.Time.Clock (diffUTCTime)
+import qualified Prometheus as P
 import Stackage.Database (SnapName)
 
 parseLtsPair :: Text -> Maybe (Int, Int)
@@ -35,3 +37,26 @@ haddockUrl sname pkgver name = HaddockR sname
   where
     toDash '.' = '-'
     toDash c = c
+
+track
+    :: MonadIO m
+    => String -> m a -> m a
+track name inner = do
+    start <- liftIO getCurrentTime
+    result <- inner
+    end <- liftIO getCurrentTime
+    let latency = fromRational $ toRational (end `diffUTCTime` start) * 1000000
+    liftIO (P.withLabel name (P.observe latency) duration)
+    return result
+  where
+    {-# NOINLINE duration #-}
+    duration :: P.Metric (P.Vector P.Label1 P.Summary)
+    duration =
+        P.unsafeRegisterIO
+            (P.vector
+                 "fn"
+                 (P.summary
+                      (P.Info
+                           "stackage_server_fn"
+                           "Stackage Server function call (duration in microseconds).")
+                      P.defaultQuantiles))

stack.yaml

@@ -6,3 +6,7 @@ image:
         add:
             config: /app/config
             static: /app/static
+extra-deps:
+    - prometheus-client-0.1.0.1
+    - prometheus-metrics-ghc-0.1.0.1
+    - wai-middleware-prometheus-0.1.0.1

stackage-server.cabal

@@ -115,6 +115,8 @@ library
                   , monad-logger                  >= 0.3.13      &&   < 0.4
                   , mtl                           >= 2.2         &&   < 2.3
                   , mwc-random                    >= 0.13        &&   < 0.14
+                  , prometheus-client
+                  , prometheus-metrics-ghc
                   , persistent                    >= 2.2         &&   < 2.3
                   , persistent-template           >= 2.1         &&   < 2.2
                   , resourcet                     >= 1.1.6       &&   < 1.2
@@ -130,6 +132,7 @@ library
                   , wai                           >= 3.2         &&   < 3.3
                   , wai-extra                     >= 3.0         &&   < 3.1
                   , wai-logger                    >= 2.2         &&   < 2.3
+                  , wai-middleware-prometheus
                   , warp                          >= 3.2         &&   < 3.3
                   , xml-conduit                   >= 1.3         &&   < 1.4
                   , xml-types