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

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)
 
 

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

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

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
+    

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "7.23.1",
+  "version": "7.25.1",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "7.23.1",
+  "version": "7.25.1",
   "description": "",
   "keywords": [],
   "author": "",

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:
+    ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T"
-      - -threaded
-      - -rtsopts
-      - -with-rtsopts=-N
     dependencies:
       - uniworx
     when:

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
@@ -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
+                       go :: Maybe (Set (UTCTime, HealthReport)) -> LoggingT IO a
-                         d <- liftIO . newDelay . floor $ wInterval % 2
+                       go pResults = do
+                         let delay = floor $ wInterval % 2
+                         d <- liftIO $ newDelay delay
 
-                         status <- atomically $ asum
+                         $logDebugS "Notify" $ "Waiting up to " <> tshow delay <> "µs..."
-                           [ Nothing <$ waitDelay d
+                         mResults <- atomically $ asum
-                           , Just <$> do
+                           [ pResults <$ waitDelay d
+                           , do
                                results <- readTVar $ foundation ^. _appHealthReport
-                               case fromNullable results of
+                               guardOn (pResults /= Just results) $ Just results
-                                 Nothing -> retry
-                                 Just rs -> do
-                                   let status = ofoldMap1 (Max *** Min . healthReportStatus) rs
-                                   guard $ pStatus /= Just status
-                                   return status
                            ]
 
-                         case status of
+                         $logDebugS "Notify" "Checking for status/watchdog..."
-                           Just (_, Min status') -> do
+                         (*> go mResults) . void . runMaybeT $ do
-                             $logInfoS "NotifyStatus" $ toPathPiece status'
+                           results <- hoistMaybe mResults
-                             liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status'
-                           Nothing -> return ()
 
-                         case status of
+                           Min status <- hoistMaybe $ ofoldMap1 (Min . healthReportStatus . view _2) <$> fromNullable results
-                           Just (_, Min HealthSuccess) -> do
+                           $logInfoS "NotifyStatus" $ toPathPiece status
-                             $logInfoS "NotifyWatchdog" "Notify"
+                           liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status
-                             liftIO $ void Systemd.notifyWatchdog
-                           _other -> return ()
 
-                         go status
+                           now <- liftIO getCurrentTime
-                in void $ allocateLinkedAsync notifyWatchdog
+                           iforM_ (foundation ^. _appHealthCheckInterval) . curry $ \case
-        _other -> return ()
+                             (_, 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

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

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 ]

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 (AuthR _)        = i18nCrumb MsgMenuLogin         $ Just HomeR
-  breadcrumb (StaticR _)      = i18nCrumb MsgBreadcrumbStatic Nothing
+  breadcrumb (StaticR _)      = i18nCrumb MsgBreadcrumbStatic    Nothing
-  breadcrumb FaviconR         = i18nCrumb MsgBreadcrumbFavicon Nothing
+  breadcrumb FaviconR         = i18nCrumb MsgBreadcrumbFavicon   Nothing
-  breadcrumb RobotsR          = i18nCrumb MsgBreadcrumbRobots 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/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

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

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, ())

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

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

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

src/Handler/Sheet.hs

@@ -255,21 +255,29 @@ getSheetListR tid ssh csh = do
             case mbSub of
               Nothing -> cellTell mempty $ stats Nothing
               (Just (Entity sid sub@Submission{..})) ->
-                let mkCid = encrypt sid
+                let
-                    mkRoute = do
+                    mkRoute :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (Route UniWorX)
-                      cid' <- mkCid
+                    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
+          $ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType, sheetName}, _, mbSub,_)} -> case mbSub of
-              (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
+              (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, ())

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

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, ())

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

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

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

@@ -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)
 

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
-    let
+    mergeState :: MonadResource m => RWST _ () _ (ReaderT SqlBackend m) ()
-      mergeLastExec (Entity _leId CronLastExec{..})
+    mergeState = do
-        | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
+      let
-        = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime)
+        mergeLastExec (Entity _leId CronLastExec{..})
-        | otherwise = return ()
+          | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
+          = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime)
+          | otherwise = return ()
 
-      mergeQueued (Entity _qjId QueuedJob{..})
+        mergeQueued (Entity _qjId QueuedJob{..})
-        | Just job <- Aeson.parseMaybe parseJSON queuedJobContent
+          | Just job <- Aeson.parseMaybe parseJSON queuedJobContent
-        = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max queuedJobCreationTime)
+          = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max queuedJobCreationTime)
-        | otherwise = return ()
+          | otherwise = return ()
-    runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeLastExec
+      runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeLastExec
-    runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeQueued
+      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
+          when (newCrontab /= currentCrontab) $ 
-            | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
+            mapRWST (liftIO . atomically) $
-              -> do
+              liftBase . void . flip swapTVar newCrontab =<< asks jobCrontab
-                now <- liftIO $ getCurrentTime
+
-                foundation <- getYesod
+          mergeState
-                State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
+          newState <- State.get
-                case jobCtl of
+
-                  JobCtlQueue job -> lift $ queueDBJobCron job
+          let upToDate = and
-                  other -> runReaderT ?? foundation $ writeJobCtl other
+                [ ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
-            | otherwise
+                , ((==) `on` HashMap.lookup jobCtl) newState   currentState
-              -> mapRWST (liftIO . atomically) $
+                ]
-                   liftBase . void . flip swapTVar newCrontab =<< asks jobCrontab
+          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

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

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)])

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

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' <- lift $ (Right <$> o .: "authority") <|> (Left <$> o .: "authority") :: ReaderT CryptoIDKey Parser (Either Value (CryptoUUID (AuthId site)))
-  tokenAuthority <- decrypt tokenAuthority'
+  tokenAuthority <- either (return . Left) (fmap Right . decrypt) tokenAuthority'
 
   tokenRoutes        <- lift $ o .:? "routes"
   tokenAddAuth       <- lift $ o .:? "add-auth"

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

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 [[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 or PersistByteString"|]) []
+        , 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|]) []
         ]
       ]
     ]

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/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{..}

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

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

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

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}

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,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}