Merge branch 'master' of gitlab2.rz.ifi.lmu.de:uni2work/uni2work

2019-11-22 13:13:41 +01:00 · 2019-11-22 13:13:41 +01:00 · e259260e9a
commit e259260e9a
parent 534c32d9f9 46a57bc1e4
42 changed files with 499 additions and 110 deletions
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@ -2,6 +2,46 @@

 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.

+### [7.25.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.25.0...v7.25.1) (2019-11-22)
+
+
+
+## [7.25.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.24.0...v7.25.0) (2019-11-21)
+
+
+### Features
+
+* usergroups & metrics usergroup ([9204565](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9204565)), closes [#538](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/538)
+
+
+
+## [7.24.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.23.2...v7.24.0) (2019-11-21)
+
+
+### Bug Fixes
+
+* **submissions:** fix users being deleted for other submissions ([2462c68](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2462c68))
+* **watchdog:** improve status&watchdog notification ([2d4ccd6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2d4ccd6))
+* typos ([97f62b9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/97f62b9))
+* **cron-exec:** consider lastExec before executing job ([43833db](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/43833db))
+
+
+### Features
+
+* **metrics:** basic collection & export of metrics ([b8f41ef](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b8f41ef))
+
+
+
+### [7.23.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.23.1...v7.23.2) (2019-11-19)
+
+
+### Bug Fixes
+
+* **cron:** disallow jobs executing twice within scheduling precision ([bc74c9e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bc74c9e))
+* **sheet list:** only show corrections after they are finished ([d4907cd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d4907cd)), closes [#533](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/533)
+
+
+
 ### [7.23.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v7.23.0...v7.23.1) (2019-11-19)


--- a/messages/uniworx/de-de-formal.msg
+++ b/messages/uniworx/de-de-formal.msg
@ -386,6 +386,8 @@ UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig.
 UnauthorizedTokenInvalid: Ihr Authorisierungs-Token konnte nicht verarbeitet werden.
 UnauthorizedTokenInvalidRoute: Ihr Authorisierungs-Token ist auf dieser Unterseite nicht gültig.
 UnauthorizedTokenInvalidAuthority: Ihr Authorisierungs-Token basiert auf den Rechten eines Nutzers, der nicht mehr existiert.
+UnauthorizedTokenInvalidAuthorityGroup: Ihr Authorisierungs-Token basiert auf den Rechten einer Gruppe von Nutzern, die nicht mehr existiert.
+UnauthorizedTokenInvalidAuthorityValue: Ihr Authorisierungs-Token basiert auf Rechten, deren Spezifikation nicht interpretiert werden konnte.
 UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden.
 UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
 UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
@ -1169,6 +1171,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 +1201,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 +2134,7 @@ CommCourse: Kursmitteilung
 CommTutorial: Tutorium-Mitteilung
 Clone: Klonen
 Deficit: Defizit
+
+MetricNoSamples: Keine Messwerte
+MetricName: Name
+MetricValue: Wert
--- 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
--- a/models/users.model
+++ b/models/users.model
@ -83,3 +83,12 @@ StudyTermCandidate    -- No one at LMU is willing and able to tell us the meanin
    key           Int      -- a possible key for the studyTermName
    name          Text     -- studyTermName as plain text from LDAP
    deriving Show Eq Ord
+
+UserGroupMember
+    group         UserGroupName
+    user          UserId
+    primary       Checkmark nullable
+
+    UniquePrimaryUserGroupMember group primary !force
+    UniqueUserGroupMember group user
+    
--- a/package-lock.json
+++ b/package-lock.json
@ -1,6 +1,6 @@
 {
  "name": "uni2work",
-  "version": "7.23.1",
+  "version": "7.25.1",
  "lockfileVersion": 1,
  "requires": true,
  "dependencies": {
--- a/package.json
+++ b/package.json
@ -1,6 +1,6 @@
 {
  "name": "uni2work",
-  "version": "7.23.1",
+  "version": "7.25.1",
  "description": "",
  "keywords": [],
  "author": "",
--- a/package.yaml
+++ b/package.yaml
@ -1,5 +1,5 @@
 name:    uniworx
-version: 7.23.1
+version: 7.25.1

 dependencies:
  - base >=4.9.1.0 && <5
@ -141,6 +141,9 @@ dependencies:
  - generic-lens
  - array
  - cookie
+  - prometheus-client
+  - prometheus-metrics-ghc
+  - wai-middleware-prometheus

 other-extensions:
  - GeneralizedNewtypeDeriving
@ -234,10 +237,7 @@ executables:
  uniworx:
    main: main.hs
    source-dirs: app
-    ghc-options:
-      - -threaded
-      - -rtsopts
-      - -with-rtsopts=-N
+    ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T"
    dependencies:
      - uniworx
    when:
--- a/3
+++ b/3
@ -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
--- 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
@ -81,12 +84,20 @@ import Network.Socket (socketPort, Socket, PortNumber)
 import qualified Network.Socket as Socket (close)

 import Control.Concurrent.STM.Delay
-import Control.Monad.STM (retry)
 import Control.Monad.Trans.Cont (runContT, callCC)

 import qualified Data.Set as Set

-import Data.Semigroup (Max(..), Min(..))
+import Data.Semigroup (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.)
@ -111,6 +122,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 +136,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 +304,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 +366,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
@ -425,39 +480,46 @@ appMain = runResourceT $ do
      case watchdogMicroSec of
        Just wInterval
          | maybe True (== myProcessID) watchdogProcess
-            -> let notifyWatchdog :: IO ()
+            -> let notifyWatchdog :: forall a. IO a
                   notifyWatchdog = runAppLoggingT foundation $ go Nothing
                     where
-                       go pStatus = do
-                         d <- liftIO . newDelay . floor $ wInterval % 2
+                       go :: Maybe (Set (UTCTime, HealthReport)) -> LoggingT IO a
+                       go pResults = do
+                         let delay = floor $ wInterval % 2
+                         d <- liftIO $ newDelay delay

-                         status <- atomically $ asum
-                           [ Nothing <$ waitDelay d
-                           , Just <$> do
+                         $logDebugS "Notify" $ "Waiting up to " <> tshow delay <> "µs..."
+                         mResults <- atomically $ asum
+                           [ pResults <$ waitDelay d
+                           , do
                               results <- readTVar $ foundation ^. _appHealthReport
-                               case fromNullable results of
-                                 Nothing -> retry
-                                 Just rs -> do
-                                   let status = ofoldMap1 (Max *** Min . healthReportStatus) rs
-                                   guard $ pStatus /= Just status
-                                   return status
+                               guardOn (pResults /= Just results) $ Just results
                           ]

-                         case status of
-                           Just (_, Min status') -> do
-                             $logInfoS "NotifyStatus" $ toPathPiece status'
-                             liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status'
-                           Nothing -> return ()
+                         $logDebugS "Notify" "Checking for status/watchdog..."
+                         (*> go mResults) . void . runMaybeT $ do
+                           results <- hoistMaybe mResults

-                         case status of
-                           Just (_, Min HealthSuccess) -> do
-                             $logInfoS "NotifyWatchdog" "Notify"
-                             liftIO $ void Systemd.notifyWatchdog
-                           _other -> return ()
+                           Min status <- hoistMaybe $ ofoldMap1 (Min . healthReportStatus . view _2) <$> fromNullable results
+                           $logInfoS "NotifyStatus" $ toPathPiece status
+                           liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status

-                         go status
-                in void $ allocateLinkedAsync notifyWatchdog
-        _other -> return ()
+                           now <- liftIO getCurrentTime
+                           iforM_ (foundation ^. _appHealthCheckInterval) . curry $ \case
+                             (_, Nothing) -> return ()
+                             (hc, Just interval) -> do
+                               lastSuccess <- hoistMaybe $ results
+                                 & Set.filter (\(_, rep) -> classifyHealthReport rep == hc)
+                                 & Set.filter (\(_, rep) -> healthReportStatus rep >= HealthSuccess)
+                                 & Set.mapMonotonic (view _1)
+                                 & Set.lookupMax
+                               guard $ lastSuccess > addUTCTime (negate interval) now
+                           $logInfoS "NotifyWatchdog" "Notify"
+                           liftIO $ void Systemd.notifyWatchdog
+                in do
+                     $logDebugS "Notify" "Spawning notify thread..."
+                     void $ allocateLinkedAsync notifyWatchdog
+        _other -> $logWarnS "Notify" "Not sending notifications of status/poking watchdog"

      let runWarp socket = runSettingsSocket (warpSettings foundation) socket app
      case sockets of
--- a/src/Cron.hs
+++ b/src/Cron.hs
@ -155,7 +155,7 @@ nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry
              -> UTCTime -- ^ Current time, used only for `CronCalendar`
              -> Cron
              -> CronNextMatch UTCTime
-nextCronMatch tz mPrev prec now c@Cron{..} = case notAfter of
+nextCronMatch tz mPrev prec now c@Cron{..} = onlyOnceWithinPrec $ case notAfter of
  MatchAsap -> MatchNone
  MatchAt ts
    | MatchAt ts' <- nextMatch
@ -165,6 +165,16 @@ nextCronMatch tz mPrev prec now c@Cron{..} = case notAfter of
    | otherwise -> MatchNone
  MatchNone -> nextMatch
  where
+    onlyOnceWithinPrec sched = case mPrev of
+      Nothing -> sched
+      Just prevT -> case sched of
+        MatchAsap
+          | now >= addUTCTime prec prevT -> MatchAsap
+          | otherwise -> MatchAt $ addUTCTime prec prevT
+        MatchAt ts -> let ts' = max ts $ addUTCTime prec prevT
+                       in if | ts' <= addUTCTime prec now -> MatchAsap
+                             | otherwise -> MatchAt ts'
+        MatchNone  -> MatchNone
    notAfter
      | Right c' <- cronNotAfter
      , Just ref <- notAfterRef
@ -207,13 +217,13 @@ nextCronMatch tz mPrev prec now c@Cron{..} = case notAfter of

    execRef ref wasExecd cronAbsolute = case execRef' ref wasExecd cronAbsolute of
      MatchAt t
-        | t <= addUTCTime prec ref -> MatchAsap
+        | t <= ref -> MatchAsap
      other -> other

    execRef' ref wasExecd cronAbsolute = case cronAbsolute of
      CronAsap -> MatchAt ref
      CronTimestamp{ cronTimestamp = localTimeToUTCTZ tz -> ts }
-        | ref <= addUTCTime prec ts || not wasExecd -> MatchAt ts
+        | ref <= ts || not wasExecd -> MatchAt ts
        | otherwise -> MatchNone
      CronCalendar{..} -> listToMatch $ do
        let
@ -341,7 +351,7 @@ nextCronMatch tz mPrev prec now c@Cron{..} = case notAfter of
        let localTimeOfDay = TimeOfDay (fromIntegral mCronHour) (fromIntegral mCronMinute) (fromIntegral mCronSecond)
            res = localTimeToUTCTZ tz LocalTime{..}

-        guard $ addUTCTime prec res >= ref
+        guard $ res >= ref

        return res
      CronNotScheduled -> MatchNone
--- a/src/Data/Universe/Instances/Reverse/WithIndex.hs
+++ b/src/Data/Universe/Instances/Reverse/WithIndex.hs
@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Universe.Instances.Reverse.WithIndex
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Universe
+import Control.Lens.Indexed
+
+import Data.Universe.Instances.Reverse ()
+
+import qualified Data.Map as Map
+
+
+instance Finite a => FoldableWithIndex a ((->) a) where
+  ifoldMap f g = fold [ f x (g x) | x <- universeF ]
+instance (Ord a, Finite a) => TraversableWithIndex a ((->) a) where
+  itraverse f g = (Map.!) . Map.fromList <$> sequenceA [ (x, ) <$> f x (g x) | x <- universeF ]
--- 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
@ -359,7 +360,15 @@ validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo vali
    validateToken' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
      guardMExceptT (maybe True (HashSet.member route) tokenRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)

-      User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority
+      tokenAuthority' <- case tokenAuthority of
+        Left tVal
+          | JSON.Success groupName <- JSON.fromJSON tVal -> maybeT (throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . hoist lift $ do
+              Entity _ UserGroupMember{..} <- MaybeT . getBy $ UniquePrimaryUserGroupMember groupName Active
+              return userGroupMemberUser
+          | otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue
+        Right uid -> return uid
+        
+      User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority'
      guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)

      let
@ -369,7 +378,7 @@ validateToken mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo vali

      authorityVal <- do
        dnf <- either throwM return $ routeAuthTags route
-        fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just tokenAuthority) route isWrite
+        fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just tokenAuthority') route isWrite
      guardExceptT (is _Authorized authorityVal) authorityVal

      whenIsJust tokenAddAuth $ \addDNF -> do
@ -1680,10 +1689,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
--- a/src/Foundation/Routes.hs
+++ 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")
--- 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)
--- a/src/Handler/Course/LecturerInvite.hs
+++ b/src/Handler/Course/LecturerInvite.hs
@ -66,7 +66,7 @@ lecturerInvitationConfig = InvitationConfig{..}
    invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
    invitationTokenConfig _ _ = do
-      itAuthority <- liftHandler requireAuthId
+      itAuthority <- Right <$> liftHandler requireAuthId
      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
    invitationRestriction _ _ = return Authorized
    invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandler $ toJunction <$> case mlType of
--- a/src/Handler/Course/ParticipantInvite.hs
+++ b/src/Handler/Course/ParticipantInvite.hs
@ -83,7 +83,7 @@ participantInvitationConfig = InvitationConfig{..}
    invitationHeading     (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
    invitationExplanation  _                    _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
    invitationTokenConfig _ _ = do
-      itAuthority <- liftHandler requireAuthId
+      itAuthority <- Right <$> liftHandler requireAuthId
      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
    invitationRestriction _ _ = return Authorized
    invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
--- a/src/Handler/Exam/CorrectorInvite.hs
+++ b/src/Handler/Exam/CorrectorInvite.hs
@ -67,7 +67,7 @@ examCorrectorInvitationConfig = InvitationConfig{..}
    invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
    invitationTokenConfig _ _ = do
-      itAuthority <- liftHandler requireAuthId
+      itAuthority <- Right <$> liftHandler requireAuthId
      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
    invitationRestriction _ _ = return Authorized
    invitationForm _ _ _ = pure (JunctionExamCorrector, ())
--- a/src/Handler/Exam/RegistrationInvite.hs
+++ b/src/Handler/Exam/RegistrationInvite.hs
@ -77,7 +77,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
    invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName
    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
    invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do
-      itAuthority <- liftHandler requireAuthId
+      itAuthority <- Right <$> liftHandler requireAuthId
      let itExpiresAt = Just $ Just invDBExamRegistrationDeadline
          itAddAuth
            | not invDBExamRegistrationCourseRegister
--- a/src/Handler/ExamOffice/Users.hs
+++ b/src/Handler/ExamOffice/Users.hs
@ -67,7 +67,7 @@ examOfficeUserInvitationConfig = InvitationConfig{..}
      return . SomeMessage $ MsgExamOfficeUserInviteHeading userDisplayName
    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamOfficeUserInviteExplanation}|]
    invitationTokenConfig _ _ = do
-      itAuthority <- liftHandler requireAuthId
+      itAuthority <- Right <$> liftHandler requireAuthId
      let itExpiresAt = Nothing
          itStartsAt = Nothing
          itAddAuth = Nothing
--- a/src/Handler/Metrics.hs
+++ b/src/Handler/Metrics.hs
@ -0,0 +1,45 @@
+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
+import qualified Data.HashSet as HashSet
+
+
+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
+
+      metricsToken <- runMaybeT . hoist runDB $ do
+        uid <- MaybeT maybeAuthId
+        guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid
+
+        encodeToken =<< bearerToken (Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
+  
+      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
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@ -250,26 +250,34 @@ getSheetListR tid ssh csh = do
                      return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
                in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{cid2}|])
      , sortable (Just "rating") (i18nCell MsgRating)
-          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub,_)} ->
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub,_)} -> 
            let stats = sheetTypeSum sheetType in -- for statistics over all shown rows
            case mbSub of
              Nothing -> cellTell mempty $ stats Nothing
              (Just (Entity sid sub@Submission{..})) ->
-                let mkCid = encrypt sid
-                    mkRoute = do
-                      cid' <- mkCid
+                let
+                    mkRoute :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (Route UniWorX)
+                    mkRoute = liftHandler $ do
+                      cid' <- encrypt sid
                      return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
                    mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this
                    acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
-                in cellTell acell $ stats submissionRatingPoints
+                    tellStats = do
+                      r <- mkRoute
+                      showRating <- hasReadAccessTo r
+                      tell . stats $ bool Nothing submissionRatingPoints showRating
+                in acell & cellContents %~ (<* tellStats)

      , sortable Nothing -- (Just "percent")
                        (i18nCell MsgRatingPercent)
-          $ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType}, _, mbSub,_)} -> case mbSub of
-              (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
+          $ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType, sheetName}, _, mbSub,_)} -> case mbSub of
+              (Just (Entity sid Submission{submissionRatingPoints=Just sPoints})) ->
                case preview (_grading . _maxPoints) sType of
                  Just maxPoints
-                    | maxPoints /= 0 -> textCell $ textPercent sPoints maxPoints
+                    | maxPoints /= 0 -> cell $ do
+                        cID <- encrypt sid
+                        showRating <- hasReadAccessTo $ CSubmissionR tid ssh csh sheetName cID CorrectionR
+                        bool (return ()) (toWidget . toMessage $ textPercent sPoints maxPoints) showRating
                  _other -> mempty
              _other -> mempty
      ]
@ -880,7 +888,7 @@ correctorInvitationConfig = InvitationConfig{..}
    invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
    invitationTokenConfig _ _ = do
-      itAuthority <- liftHandler requireAuthId
+      itAuthority <- Right <$> liftHandler requireAuthId
      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
    invitationRestriction _ _ = return Authorized
    invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure $ (JunctionSheetCorrector cLoad cState, ())
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@ -107,7 +107,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
    invitationTokenConfig (Entity _ Submission{..}) _ = do
      Sheet{..} <- getJust submissionSheet
      Course{..} <- getJust sheetCourse
-      itAuthority <- liftHandler requireAuthId
+      itAuthority <- Right <$> liftHandler requireAuthId
      itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR)
      let itExpiresAt = Nothing
          itStartsAt = Nothing
@ -486,7 +486,7 @@ submissionHelper tid ssh csh shn mcid = do
            | otherwise -> case change of
              Left subEmail -> deleteInvitation @SubmissionUser smid subEmail
              Right subUid  -> do
-                deleteWhere [SubmissionUserUser ==. subUid]
+                deleteBy $ UniqueSubmissionUser subUid smid
                audit $ TransactionSubmissionUserDelete smid subUid
          
          addMessageI Success $ if | Nothing <- msmid -> MsgSubmissionCreated
--- a/src/Handler/Tutorial/TutorInvite.hs
+++ b/src/Handler/Tutorial/TutorInvite.hs
@ -64,7 +64,7 @@ tutorInvitationConfig = InvitationConfig{..}
    invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
    invitationTokenConfig _ _ = do
-      itAuthority <- liftHandler requireAuthId
+      itAuthority <- Right <$> liftHandler requireAuthId
      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
    invitationRestriction _ _ = return Authorized
    invitationForm _ _ _ = pure (JunctionTutor, ())
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@ -572,7 +572,7 @@ functionInvitationConfig = InvitationConfig{..}
      MsgRenderer mr <- getMsgRenderer
      return [ihamlet|_{SomeMessage $ MsgSchoolFunctionInviteExplanation (mr $ SomeMessage invTokenUserFunctionFunction)}|]
    invitationTokenConfig _ (InvDBDataUserFunction{..}, _) = do
-      itAuthority <- liftHandler requireAuthId
+      itAuthority <- Right <$> liftHandler requireAuthId
      let itExpiresAt = Just $ Just invDBUserFunctionDeadline
          itAddAuth = Nothing
          itStartsAt = Nothing
--- a/src/Handler/Utils/Invitations.hs
+++ b/src/Handler/Utils/Invitations.hs
@ -144,7 +144,7 @@ data InvitationConfig junction = forall formCtx. InvitationConfig

 -- | Additional configuration needed for an invocation of `bearerToken`
 data InvitationTokenConfig = InvitationTokenConfig
-  { itAuthority :: UserId
+  { itAuthority :: Either Value UserId
  , itAddAuth   :: Maybe AuthDNF
  , itExpiresAt :: Maybe (Maybe UTCTime)
  , itStartsAt  :: Maybe UTCTime
--- a/src/Handler/Utils/Routes.hs
+++ 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)
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@ -142,6 +142,7 @@ import Text.Blaze.Instances as Import ()
 import Jose.Jwt.Instances as Import ()
 import Web.PathPieces.Instances as Import ()
 import Data.Universe.Instances.Reverse.MonoTraversable ()
+import Data.Universe.Instances.Reverse.WithIndex ()
 import Database.Persist.Class.Instances as Import ()
 import Database.Persist.Types.Instances as Import ()
 import Data.UUID.Instances as Import ()
@ -152,6 +153,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)

--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@ -251,23 +251,26 @@ execCrontab :: RWST JobContext () (HashMap JobCtl (Max UTCTime)) (HandlerFor Uni
 -- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have
 --   seen, wait for the time of the next job and fire it
 execCrontab = do
-  mapRWST (liftHandler . runDB . setSerializable) $ do
-    let
-      mergeLastExec (Entity _leId CronLastExec{..})
-        | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
-        = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime)
-        | otherwise = return ()
+  let
+    mergeState :: MonadResource m => RWST _ () _ (ReaderT SqlBackend m) ()
+    mergeState = do
+      let
+        mergeLastExec (Entity _leId CronLastExec{..})
+          | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
+          = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime)
+          | otherwise = return ()

-      mergeQueued (Entity _qjId QueuedJob{..})
-        | Just job <- Aeson.parseMaybe parseJSON queuedJobContent
-        = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max queuedJobCreationTime)
-        | otherwise = return ()
-    runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeLastExec
-    runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeQueued
+        mergeQueued (Entity _qjId QueuedJob{..})
+          | Just job <- Aeson.parseMaybe parseJSON queuedJobContent
+          = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max queuedJobCreationTime)
+          | otherwise = return ()
+      runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeLastExec
+      runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeQueued
+  mapRWST (liftHandler . runDB . setSerializable) $ mergeState

  refT <- liftIO getCurrentTime
  settings <- getsYesod appSettings'
-  (currentCrontab, (jobCtl, nextMatch)) <- mapRWST (liftIO . atomically) $ do
+  (currentCrontab, (jobCtl, nextMatch), currentState) <- mapRWST (liftIO . atomically) $ do
    crontab <- liftBase . readTVar =<< asks jobCrontab

    State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
@ -275,7 +278,7 @@ execCrontab = do
    case earliestJob settings prevExec crontab refT of
      Nothing -> liftBase retry
      Just (_, MatchNone) -> liftBase retry
-      Just x -> return (crontab, x)
+      Just x -> return (crontab, x, prevExec)

  do
    lastTimes <- State.get
@ -284,18 +287,24 @@ execCrontab = do

  let doJob = mapRWST (liftHandler . runDBJobs . setSerializable) $ do
          newCrontab <- lift . hoist lift $ determineCrontab'
-          if
-            | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
-              -> do
-                now <- liftIO $ getCurrentTime
-                foundation <- getYesod
-                State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
-                case jobCtl of
-                  JobCtlQueue job -> lift $ queueDBJobCron job
-                  other -> runReaderT ?? foundation $ writeJobCtl other
-            | otherwise
-              -> mapRWST (liftIO . atomically) $
-                   liftBase . void . flip swapTVar newCrontab =<< asks jobCrontab
+          when (newCrontab /= currentCrontab) $ 
+            mapRWST (liftIO . atomically) $
+              liftBase . void . flip swapTVar newCrontab =<< asks jobCrontab
+
+          mergeState
+          newState <- State.get
+
+          let upToDate = and
+                [ ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
+                , ((==) `on` HashMap.lookup jobCtl) newState   currentState
+                ]
+          when upToDate $ do
+            now <- liftIO $ getCurrentTime
+            foundation <- getYesod
+            State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
+            case jobCtl of
+              JobCtlQueue job -> lift $ queueDBJobCron job
+              other -> runReaderT ?? foundation $ writeJobCtl other

  case nextMatch of
    MatchAsap -> doJob
--- a/src/Jobs/Handler/ChangeUserDisplayEmail.hs
+++ b/src/Jobs/Handler/ChangeUserDisplayEmail.hs
@ -12,7 +12,7 @@ import Text.Hamlet

 dispatchJobChangeUserDisplayEmail :: UserId -> UserEmail -> Handler ()
 dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = do
-  token <- tokenRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken jUser (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
+  token <- tokenRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (Right jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
  jwt <- encodeToken token
  let
    setDisplayEmailUrl :: SomeRoute UniWorX
--- a/src/Jobs/Handler/SendNotification/Utils.hs
+++ b/src/Jobs/Handler/SendNotification/Utils.hs
@ -16,7 +16,7 @@ ihamletSomeMessage f trans = f $ trans . SomeMessage
 mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
 mkEditNotifications uid = liftHandler $ do
  cID <- encrypt uid
-  jwt <- encodeToken =<< bearerToken uid (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
+  jwt <- encodeToken =<< bearerToken (Right uid) (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
  let
    editNotificationsUrl :: SomeRoute UniWorX
    editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)])
--- a/src/Jobs/Handler/SendPasswordReset.hs
+++ b/src/Jobs/Handler/SendPasswordReset.hs
@ -29,7 +29,7 @@ dispatchJobSendPasswordReset jRecipient = userMailT jRecipient $ do
      LTUUnique utc' _ -> utc'
      _other           -> UTCTime (addDays 2 $ utctDay now) 0

-  resetToken' <- bearerToken jRecipient (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
+  resetToken' <- bearerToken (Right jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
  let resetToken = resetToken'
        & tokenRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
  encodedToken <- encodeToken resetToken
--- a/src/Model/Tokens.hs
+++ b/src/Model/Tokens.hs
@ -46,7 +46,7 @@ import Data.Binary (Binary)
 data BearerToken site = BearerToken
  { tokenIdentifier   :: TokenId
    -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
-  , tokenAuthority    :: AuthId site
+  , tokenAuthority    :: Either Value (AuthId site)
    -- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
  , tokenRoutes       :: Maybe (HashSet (Route site))
    -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
@ -97,7 +97,7 @@ tokenToJSON :: forall m.
 --
 -- Monadic context is needed because `AuthId`s are encrypted during encoding
 tokenToJSON BearerToken{..} = do
-  cID <- encrypt tokenAuthority :: m (CryptoUUID (AuthId (HandlerSite m)))
+  cID <- either (return . Left) (fmap Right . encrypt) tokenAuthority :: m (Either Value (CryptoUUID (AuthId (HandlerSite m))))
  let stdPayload = Jose.JwtClaims
        { jwtIss = Just $ toPathPiece tokenIssuedBy
        , jwtSub = Nothing
@ -108,7 +108,7 @@ tokenToJSON BearerToken{..} = do
        , jwtJti = Just $ toPathPiece tokenIdentifier
        }
  return . JSON.object $
-    catMaybes [ Just $ "authority" .= cID
+    catMaybes [ Just $ "authority" .= either id toJSON cID
              , ("routes" .=) <$> tokenRoutes
              , ("add-auth" .=) <$> tokenAddAuth
              , ("restrictions" .=) <$> assertM' (not . HashMap.null) tokenRestrictions
@ -128,8 +128,8 @@ tokenParseJSON :: forall site.
 --
 -- It's usually easier to use `Utils.Tokens.tokenParseJSON'`
 tokenParseJSON v@(Object o) = do
-  tokenAuthority' <- lift (o .: "authority") :: ReaderT CryptoIDKey Parser (CryptoUUID (AuthId site))
-  tokenAuthority <- decrypt tokenAuthority'
+  tokenAuthority' <- lift $ (Right <$> o .: "authority") <|> (Left <$> o .: "authority") :: ReaderT CryptoIDKey Parser (Either Value (CryptoUUID (AuthId site)))
+  tokenAuthority <- either (return . Left) (fmap Right . decrypt) tokenAuthority'

  tokenRoutes        <- lift $ o .:? "routes"
  tokenAddAuth       <- lift $ o .:? "add-auth"
--- a/src/Model/Types/Security.hs
+++ b/src/Model/Types/Security.hs
@ -21,6 +21,11 @@ import qualified Data.Aeson.Types as Aeson

 import qualified Data.Binary as Binary

+import qualified Data.CaseInsensitive as CI
+
+import Model.Types.TH.PathPiece
+import Database.Persist.Sql
+

 data AuthenticationMode = AuthLDAP
                        | AuthPWHash { authPWHash :: Text }
@ -152,3 +157,21 @@ instance (Ord a, Binary a) => Binary (PredDNF a) where
 type AuthLiteral = PredLiteral AuthTag

 type AuthDNF = PredDNF AuthTag
+
+
+data UserGroupName
+  = UserGroupMetrics
+  | UserGroupCustom { userGroupCustomName :: CI Text }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance PathPiece UserGroupName where
+  toPathPiece UserGroupMetrics = "metrics"
+  toPathPiece (UserGroupCustom t) = CI.original t
+  fromPathPiece t = Just $ if
+    | "metrics" `ciEq` t -> UserGroupMetrics
+    | otherwise          -> UserGroupCustom $ CI.mk t
+    where
+      ciEq = (==) `on` CI.mk
+
+pathPieceJSON ''UserGroupName
+derivePersistFieldPathPiece' (sqlType (Proxy @(CI Text))) ''UserGroupName
--- a/src/Model/Types/TH/PathPiece.hs
+++ b/src/Model/Types/TH/PathPiece.hs
@ -1,5 +1,6 @@
 module Model.Types.TH.PathPiece
  ( derivePersistFieldPathPiece
+  , derivePersistFieldPathPiece'
  ) where

 import ClassyPrelude.Yesod
@ -13,7 +14,10 @@ import Language.Haskell.TH.Datatype


 derivePersistFieldPathPiece :: Name -> DecsQ
-derivePersistFieldPathPiece tName = do
+derivePersistFieldPathPiece = derivePersistFieldPathPiece' SqlString
+
+derivePersistFieldPathPiece' :: SqlType -> Name -> DecsQ
+derivePersistFieldPathPiece' sType tName = do
  DatatypeInfo{..} <- reifyDatatype tName
  vars <- forM datatypeVars (const $ newName "a")
  let t = foldl (\t' n' -> t' `appT` varT n') (conT tName) vars
@ -32,15 +36,18 @@ derivePersistFieldPathPiece tName = do
        [ do
            bs <- newName "bs"
            clause [[p|PersistByteString $(varP bs)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistByteString") Right $ fromPathPiece =<< either (const Nothing) Just (Text.decodeUtf8' $(varE bs))|]) []
+        , do
+            bs <- newName "bs"
+            clause [[p|PersistDbSpecific $(varP bs)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistDbSpecific") Right $ fromPathPiece =<< either (const Nothing) Just (Text.decodeUtf8' $(varE bs))|]) []
        , do
            text <- newName "text"
-            clause [[p|PersistText $(varP text)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistTetx") Right $ fromPathPiece $(varE text)|]) []
-        , clause [wildP] (normalB [e|Left "PathPiece values must be converted from PersistText or PersistByteString"|]) []
+            clause [[p|PersistText $(varP text)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistText") Right $ fromPathPiece $(varE text)|]) []
+        , clause [wildP] (normalB [e|Left "PathPiece values must be converted from PersistText, PersistByteString, or PersistDbSpecific"|]) []
        ]
      ]
    , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
      [ funD 'sqlType
-        [ clause [wildP] (normalB [e|SqlString|]) []
+        [ clause [wildP] (normalB [e|sType|]) []
        ]
      ]
    ]
--- a/src/Prometheus/Instances.hs
+++ 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
+    ]
--- a/src/Utils/Sql.hs
+++ b/src/Utils/Sql.hs
@ -28,7 +28,7 @@ setSerializable act = recovering policy [logRetries suggestRetry logRetry] act'
             -> SqlError
             -> RetryStatus
             -> ReaderT SqlBackend m ()
-    logRetry shouldRetry err status = $logDebugS "Sql" . pack $ defaultLogMsg shouldRetry err status
+    logRetry shouldRetry err status = $logDebugS "SQL" . pack $ defaultLogMsg shouldRetry err status

    act' :: RetryStatus -> ReaderT SqlBackend m a
    act' RetryStatus{..}
--- a/src/Utils/TH/Routes.hs
+++ 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
--- a/src/Utils/Tokens.hs
+++ b/src/Utils/Tokens.hs
@ -58,7 +58,7 @@ bearerToken :: forall m.
               , HasInstanceID (HandlerSite m) InstanceId
               , HasAppSettings (HandlerSite m)
               )
-            => AuthId (HandlerSite m)
+            => Either Value (AuthId (HandlerSite m))
            -> Maybe (HashSet (Route (HandlerSite m)))
            -> Maybe AuthDNF
            -> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
--- 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
--- a/start.sh
+++ b/start.sh
@ -6,7 +6,7 @@ set -e

 __HOST=${HOST:-$(hostname -s | awk '{ print $0; }')}

-export DETAILED_LOGGING=${DETAILED_LOGGIN:-true}
+export DETAILED_LOGGING=${DETAILED_LOGGING:-true}
 export LOG_ALL=${LOG_ALL:-false}
 export LOGLEVEL=${LOGLEVEL:-info}
 export DUMMY_LOGIN=${DUMMY_LOGIN:-true}
--- 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;
--- a/templates/metrics.hamlet
+++ b/templates/metrics.hamlet
@ -0,0 +1,46 @@
+$newline never
+$maybe t <- metricsToken
+  <section>
+    <pre style="font-family: monospace; white-space: pre-wrap; word-break: break-all;">
+      #{toPathPiece t}
+<section>
+  <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}