diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index d5615c318..ac34ebfd6 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/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 \ No newline at end of file diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 99313f48a..8f56e6a86 100644 --- a/messages/uniworx/en-eu.msg +++ b/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 \ No newline at end of file diff --git a/package.yaml b/package.yaml index 178fc67f7..b914b4d2d 100644 --- a/package.yaml +++ b/package.yaml @@ -141,6 +141,9 @@ dependencies: - generic-lens - array - cookie + - prometheus-client + - prometheus-metrics-ghc + - wai-middleware-prometheus other-extensions: - GeneralizedNewtypeDeriving diff --git a/routes b/routes index af3ba9fc1..469ec0297 100644 --- a/routes +++ b/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 diff --git a/src/Application.hs b/src/Application.hs index 41ca6fed4..b1f13b800 100644 --- a/src/Application.hs +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 2470d2088..4ac262136 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs new file mode 100644 index 000000000..614bdea6d --- /dev/null +++ b/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") diff --git a/src/Handler/Common.hs b/src/Handler/Common.hs index f11a76cfb..da1330be9 100644 --- a/src/Handler/Common.hs +++ b/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) diff --git a/src/Handler/Metrics.hs b/src/Handler/Metrics.hs new file mode 100644 index 000000000..72ebd06a3 --- /dev/null +++ b/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 diff --git a/src/Handler/Utils/Routes.hs b/src/Handler/Utils/Routes.hs new file mode 100644 index 000000000..52a93dfed --- /dev/null +++ b/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) diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 13d03d064..8b0082217 100644 --- a/src/Import/NoModel.hs +++ b/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) diff --git a/src/Prometheus/Instances.hs b/src/Prometheus/Instances.hs new file mode 100644 index 000000000..ba217324b --- /dev/null +++ b/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 + ] diff --git a/src/Utils/TH/Routes.hs b/src/Utils/TH/Routes.hs new file mode 100644 index 000000000..18f8a7805 --- /dev/null +++ b/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 diff --git a/stack.yaml b/stack.yaml index f83be73a7..a5abb45dd 100644 --- a/stack.yaml +++ b/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 diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index b6fc07906..11355082b 100644 --- a/templates/default-layout.lucius +++ b/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; diff --git a/templates/metrics.hamlet b/templates/metrics.hamlet new file mode 100644 index 000000000..9f4a780a3 --- /dev/null +++ b/templates/metrics.hamlet @@ -0,0 +1,41 @@ +$newline never +
+ $forall SampleGroup Info{..} _ mSamples <- samples +
+
#{metricName} +

+ #{metricHelp} +

+ $case mSamples + $of [] +

_{MsgMetricNoSamples} + $of _ + $maybe (lPairs, sValue) <- singleSample metricName mSamples +

+ #{decodeUtf8 sValue} + $case lPairs + $of [] + $of _ +