feat(metrics): basic collection & export of metrics

messages/uniworx/de-de-formal.msg

@@ -1169,6 +1169,7 @@ BreadcrumbUser: Benutzer
 BreadcrumbStatic: Statische Resource
 BreadcrumbFavicon: Favicon
 BreadcrumbRobots: robots.txt
+BreadcrumbMetrics: Metriken
 BreadcrumbLecturerInvite: Einladung zum Kursverwalter
 BreadcrumbExamOfficeUserInvite: Einladung bzgl. Prüfungsleistungen
 BreadcrumbFunctionaryInvite: Einladung zum Instituts-Funktionär
@@ -1198,6 +1199,8 @@ BreadcrumbApplicationFiles: Bewerbungsdateien
 BreadcrumbCourseNewsArchive: Archiv
 BreadcrumbCourseNewsFile: Datei
 
+TitleMetrics: Metriken
+
 AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren.
 AuthPredsActive: Aktive Authorisierungsprädikate
 AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
@@ -2129,3 +2132,7 @@ CommCourse: Kursmitteilung
 CommTutorial: Tutorium-Mitteilung
 Clone: Klonen
 Deficit: Defizit
+
+MetricNoSamples: Keine Messwerte
+MetricName: Name
+MetricValue: Wert

messages/uniworx/en-eu.msg

@@ -1165,6 +1165,7 @@ BreadcrumbUser: User
 BreadcrumbStatic: Static resource
 BreadcrumbFavicon: Favicon
 BreadcrumbRobots: robots.txt
+BreadcrumbMetrics: Metrics
 BreadcrumbLecturerInvite: Invitation to be a course administrator
 BreadcrumbExamOfficeUserInvite: Invitation regarding exam achievements
 BreadcrumbFunctionaryInvite: Invitation to be a department functionary
@@ -1194,6 +1195,8 @@ BreadcrumbApplicationFiles: Application files
 BreadcrumbCourseNewsArchive: Archive
 BreadcrumbCourseNewsFile: File
 
+TitleMetrics: Metrics
+
 AuthPredsInfo: To view their own courses like a participant would, administrators and correctors can deactivate the checking of their credentials temporarily. Disabled authorisation predicates always fail. This means that deactivated predicates are not checked to grant access where it would otherwise not be permitted. These settings are only temporary, until your session expires i.e. your browser-cookie does. By deactivating predicates you can lock yourself out temporarily, at most.
 AuthPredsActive: Active authorisation predicates
 AuthPredsActiveChanged: Authorisation settings saved for the current session
@@ -2125,3 +2128,7 @@ CommCourse: Course message
 CommTutorial: Tutorial message
 Clone: Cloning
 Deficit: Deficit
+
+MetricNoSamples: No samples
+MetricName: Name
+MetricValue: Value

package.yaml

@@ -141,6 +141,9 @@ dependencies:
   - generic-lens
   - array
   - cookie
+  - prometheus-client
+  - prometheus-metrics-ghc
+  - wai-middleware-prometheus
 
 other-extensions:
   - GeneralizedNewtypeDeriving

routes

@@ -40,7 +40,8 @@
 /auth   AuthR   Auth   getAuth                                !free
 
 /favicon.ico FaviconR GET                                     !free
-/robots.txt RobotsR GET                                       !free
+/robots.txt  RobotsR  GET                                     !free
+/metrics     MetricsR GET
 
 /                             HomeR            GET            !free
 /users                        UsersR           GET POST       -- no tags, i.e. admins only

src/Application.hs

@@ -22,6 +22,8 @@ import Database.Persist.Postgresql          (createPostgresqlPool, pgConnStr,
 import Import                        hiding (cancel)
 import Language.Haskell.TH.Syntax           (qLocation)
 import Network.Wai (Middleware)
+import qualified Network.Wai as Wai
+import qualified Network.HTTP.Types as HTTP
 import Network.Wai.Handler.Warp             (Settings, defaultSettings,
                                              defaultShouldDisplayException,
                                              runSettings, runSettingsSocket, setHost,
@@ -48,6 +50,7 @@ import System.Directory
 import Jobs
 
 import qualified Data.Text.Encoding as Text
+
 import Yesod.Auth.Util.PasswordStore
 
 import qualified Data.ByteString.Lazy as LBS
@@ -88,6 +91,15 @@ import qualified Data.Set as Set
 
 import Data.Semigroup (Max(..), Min(..))
 
+import qualified Prometheus.Metric.GHC as Prometheus
+import qualified Prometheus
+
+import Data.Time.Clock.POSIX
+
+import Handler.Utils.Routes (classifyHandler)
+
+import Data.List (cycle)
+
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
 import Handler.Common
@@ -111,6 +123,7 @@ import Handler.Health
 import Handler.Exam
 import Handler.Allocation
 import Handler.ExamOffice
+import Handler.Metrics
 
 
 -- This line actually creates our YesodDispatch instance. It is the second half
@@ -124,6 +137,8 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
 -- migrations handled by Yesod.
 makeFoundation :: (MonadResource m, MonadUnliftIO m) => AppSettings -> m UniWorX
 makeFoundation appSettings'@AppSettings{..} = do
+    void $ Prometheus.register Prometheus.ghcMetrics
+  
     -- Some basic initializations: HTTP connection manager, logger, and static
     -- subsite.
     appHttpManager <- newManager
@@ -290,7 +305,39 @@ makeApplication foundation = liftIO $ do
     logWare <- makeLogWare foundation
     -- Create the WAI application and apply middlewares
     appPlain <- toWaiAppPlain foundation
-    return $ logWare $ defaultMiddlewaresNoLogging appPlain
+    return . prometheusMiddleware . logWare $ defaultMiddlewaresNoLogging appPlain
+  where
+    prometheusMiddleware :: Middleware
+    prometheusMiddleware app req respond' = do
+      start <- getPOSIXTime
+      app req $ \res -> do
+        end <- getPOSIXTime
+        let method  = decodeUtf8 $ Wai.requestMethod req
+            status  = tshow . HTTP.statusCode $ Wai.responseStatus res
+            route :: Maybe (Route UniWorX)
+            route   = parseRoute ( Wai.pathInfo req
+                                 , over (mapped . _2) (fromMaybe "") . HTTP.queryToQueryText $ Wai.queryString req
+                                 )
+            handler' = pack . classifyHandler <$> route
+
+            labels :: Prometheus.Label3
+            labels = (fromMaybe "n/a" handler', method, status)
+        Prometheus.withLabel requestLatency labels . flip Prometheus.observe . realToFrac $ end - start
+
+        respond' res
+
+{-# NOINLINE requestLatency #-}
+requestLatency :: Prometheus.Vector Prometheus.Label3 Prometheus.Histogram
+requestLatency = Prometheus.unsafeRegister
+               $ Prometheus.vector ("handler", "method", "status")
+               $ Prometheus.histogram info buckets
+  where info = Prometheus.Info "http_request_duration_seconds"
+                               "HTTP request latency"
+        buckets = map fromRational . takeWhile (<= 500) . go 50e-6 $ cycle [2, 2, 2.5]
+          where
+            go n []     = [n]
+            go n (f:fs) = n : go (f * n) fs
+
 
 makeLogWare :: MonadIO m => UniWorX -> m Middleware
 makeLogWare app = do
@@ -320,13 +367,22 @@ makeLogWare app = do
     logWare <- either mkLogWare return lookupRes
     logWare wai req fin
 
+data ReadySince = MkReadySince
+
 -- | Warp settings for the given foundation value.
 warpSettings :: UniWorX -> Settings
 warpSettings foundation = defaultSettings
     & setBeforeMainLoop (runAppLoggingT foundation $ do
                             let notifyReady = do
                                   $logInfoS "setup" "Ready"
-                                  void $ liftIO Systemd.notifyReady
+                                  void . liftIO $ do
+                                    void . Prometheus.register . readyMetric =<< getCurrentTime
+                                    Systemd.notifyReady
+                                readyMetric ts = Prometheus.Metric $ return (MkReadySince, collectReadySince)
+                                  where
+                                    collectReadySince = return $ [Prometheus.SampleGroup info Prometheus.GaugeType [Prometheus.Sample "ready_time" [] sample]]
+                                    info = Prometheus.Info "ready_time" "POSIXTime this Uni2work-instance became ready"
+                                    sample = encodeUtf8 . tshow . (realToFrac :: POSIXTime -> Nano) $ utcTimeToPOSIXSeconds ts
                             if
                               | foundation ^. _appHealthCheckDelayNotify
                                 -> void . forkIO $ do

src/Foundation.hs

@@ -8,6 +8,7 @@ module Foundation
 
 import Foundation.Type as Foundation
 import Foundation.I18n as Foundation
+import Foundation.Routes as Foundation
 
 
 import Import.NoFoundation hiding (embedFile)
@@ -107,7 +108,7 @@ import UnliftIO.Pool
 -- This function also generates the following type synonyms:
 -- type Handler x = HandlerT UniWorX IO x
 -- type Widget    = WidgetT  UniWorX IO ()
-mkYesodData "UniWorX" $(parseRoutesFile "routes")
+mkYesodData "UniWorX" uniworxRoutes
 
 deriving instance Generic CourseR
 deriving instance Generic SheetR
@@ -1680,10 +1681,11 @@ i18nCrumb msg mbR = do
 -- i.e. information might be leaked by not performing permission checks if the
 -- breadcrumb value depends on sensitive content (like an user's name).
 instance YesodBreadcrumbs UniWorX where
-  breadcrumb (AuthR _)        = i18nCrumb MsgMenuLogin   $ Just HomeR
-  breadcrumb (StaticR _)      = i18nCrumb MsgBreadcrumbStatic Nothing
-  breadcrumb FaviconR         = i18nCrumb MsgBreadcrumbFavicon Nothing
-  breadcrumb RobotsR          = i18nCrumb MsgBreadcrumbRobots Nothing
+  breadcrumb (AuthR _)        = i18nCrumb MsgMenuLogin         $ Just HomeR
+  breadcrumb (StaticR _)      = i18nCrumb MsgBreadcrumbStatic    Nothing
+  breadcrumb FaviconR         = i18nCrumb MsgBreadcrumbFavicon   Nothing
+  breadcrumb RobotsR          = i18nCrumb MsgBreadcrumbRobots    Nothing
+  breadcrumb MetricsR         = i18nCrumb MsgBreadcrumbMetrics   Nothing
 
   breadcrumb HomeR            = i18nCrumb MsgMenuHome      Nothing
   breadcrumb UsersR           = i18nCrumb MsgMenuUsers   $ Just AdminR

src/Foundation/Routes.hs

@@ -0,0 +1,10 @@
+module Foundation.Routes
+  ( uniworxRoutes
+  ) where
+
+import ClassyPrelude.Yesod
+import Yesod.Routes.TH.Types (ResourceTree)
+
+
+uniworxRoutes :: [ResourceTree String]
+uniworxRoutes = $(parseRoutesFile "routes")

src/Handler/Common.hs

@@ -1,5 +1,8 @@
 -- | Common handler functions.
-module Handler.Common where
+module Handler.Common
+  ( getFaviconR
+  , getRobotsR
+  ) where
 
 import Data.FileEmbed (embedFile)
 import Import hiding (embedFile)

src/Handler/Metrics.hs

@@ -0,0 +1,37 @@
+module Handler.Metrics
+  ( getMetricsR
+  ) where
+
+import Import hiding (Info)
+
+import Prometheus
+import qualified Network.Wai.Middleware.Prometheus as Prometheus
+
+import qualified Data.Text as Text
+
+
+getMetricsR :: Handler TypedContent
+getMetricsR = selectRep $ do
+  provideRep (sendWaiApplication Prometheus.metricsApp :: Handler Text)
+  provideRep metricsHtml
+  provideRep $ collectMetrics >>= returnJson
+  where
+    metricsHtml :: Handler Html
+    metricsHtml = do
+      samples <- collectMetrics
+      defaultLayout $ do
+        setTitleI MsgTitleMetrics
+        $(widgetFile "metrics")
+
+    metricBasename base sName
+      | Just suffix <- Text.stripPrefix base sName
+      = if | Just suffix' <- Text.stripPrefix "_" suffix
+             -> suffix'
+           | otherwise
+             -> suffix
+      | otherwise
+      = sName
+    getLabels = nub . concatMap (\(Sample _ lPairs _) -> lPairs ^.. folded . _1)
+    singleSample base [Sample sName lPairs sValue]
+      | sName == base = Just (lPairs, sValue)
+    singleSample _ _ = Nothing

src/Handler/Utils/Routes.hs

@@ -0,0 +1,11 @@
+module Handler.Utils.Routes
+  ( classifyHandler
+  ) where
+
+import Import
+
+import Utils.TH.Routes
+
+
+classifyHandler :: Route UniWorX -> String
+classifyHandler = $(classifyHandler' uniworxRoutes)

src/Import/NoModel.hs

@@ -152,6 +152,7 @@ import Crypto.Hash.Instances as Import ()
 import Colonnade.Instances as Import ()
 import Data.Bool.Instances as Import ()
 import Data.Encoding.Instances as Import ()
+import Prometheus.Instances as Import ()
 
 import Crypto.Hash as Import (Digest, SHA3_256)
 

src/Prometheus/Instances.hs

@@ -0,0 +1,29 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Prometheus.Instances
+  () where
+
+import ClassyPrelude
+import Prometheus
+import Data.Aeson
+
+import qualified Data.Map.Strict as Map
+
+
+instance ToJSON SampleType where
+  toJSON = String . tshow
+
+instance ToJSON SampleGroup where
+  toJSON (SampleGroup Info{..} sgType samples) = object
+    [ "name" .= metricName
+    , "help" .= metricHelp
+    , "type" .= sgType
+    , "metrics" .= samples
+    ]
+
+instance ToJSON Sample where
+  toJSON (Sample sName sLabels sValue) = object
+    [ "name" .= sName
+    , "labels" .= Map.fromList sLabels
+    , "value" .= decodeUtf8 sValue
+    ]

src/Utils/TH/Routes.hs

@@ -0,0 +1,25 @@
+module Utils.TH.Routes
+  ( classifyHandler'
+  ) where
+
+import ClassyPrelude
+import Yesod.Routes.TH.Types (ResourceTree, FlatResource(..), Piece(..), Dispatch(..), flatten)
+
+import Language.Haskell.TH
+
+
+classifyHandler' :: [ResourceTree String] -> ExpQ
+classifyHandler' = lamCaseE . map toMatch . flatten
+  where
+    toMatch FlatResource{..} = match (toPattern frDispatch $ frParentPieces ++ [(frName, frPieces)]) (normalB . litE $ stringL frName) []
+    toPattern _ [] = error "Empty hierarchy in toPattern"
+    toPattern dp [(mkName -> con, dynPieces -> pieces)] = conP con $ replicate pieces wildP ++ dispatchPattern dp
+    toPattern dp ( (mkName -> con, dynPieces -> pieces) : xs) = conP con $ replicate pieces wildP ++ [ toPattern dp xs ]
+    dispatchPattern (Methods Nothing _) = []
+    dispatchPattern (Methods (Just _) _) = [wildP]
+    dispatchPattern (Subsite _ _) = [wildP]
+
+    dynPieces = length . mapMaybe onlyDyn
+      where
+        onlyDyn (Static _) = Nothing
+        onlyDyn p@(Dynamic _) = Just p

stack.yaml

@@ -60,5 +60,8 @@ extra-deps:
 
   - generic-lens-1.2.0.0
 
+  - prometheus-metrics-ghc-1.0.0
+  - wai-middleware-prometheus-1.0.0
+
 resolver: lts-13.21
 allow-newer: true

templates/default-layout.lucius

@@ -558,7 +558,7 @@ ul.list--inline {
 @media (min-width: 768px) {
 
   .deflist {
-    grid-template-columns: max-content minmax(0, max-content);
+    grid-template-columns: fit-content(25vw) 1fr;
 
     .deflist {
       margin-top: -10px;

templates/metrics.hamlet

@@ -0,0 +1,41 @@
+$newline never
+<dl .deflist>
+  $forall SampleGroup Info{..} _ mSamples <- samples
+    <dt .deflist__dt>
+      <div>#{metricName}
+      <p style="font-weight: 600; color: var(--color-fontsec); font-size: 0.9rem; margin-top: 7px">
+        #{metricHelp}
+    <dd .deflist__dd style="overflow: auto; max-height: 50vh">
+      $case mSamples
+        $of []
+          <p style="font-style: italic">_{MsgMetricNoSamples}
+        $of _
+          $maybe (lPairs, sValue) <- singleSample metricName mSamples
+            <p>
+              #{decodeUtf8 sValue}
+            $case lPairs
+              $of []
+              $of _
+                <ul .list-inline .list--comma-separated>
+                  $forall (lName, lValue) <- lPairs
+                    <li>#{lName}=#{lValue}
+          $nothing
+            $with allLabels <- getLabels mSamples
+              <table .table .table--striped .table--hover>
+                <thead>
+                  <tr .table__row .table__row--head>
+                    <th .table__th>_{MsgMetricName}
+                    $forall l <- allLabels
+                      <th .table__th style="font-family: monospace">#{l}
+                    <th .table__th>_{MsgMetricValue}
+                <tbody>
+                  $forall Sample sName lPairs sValue <- mSamples
+                    <tr .table__row>
+                      <td .table__td title=#{sName}>
+                        #{metricBasename metricName sName}
+                      $forall l <- allLabels
+                        <td .table__td>
+                          $maybe lValue <- lookup l lPairs
+                            #{lValue}
+                      <td .table__td>
+                        #{decodeUtf8 sValue}