diff --git a/CHANGELOG.md b/CHANGELOG.md index 01e3b1251..7bff3b29c 100644 --- 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) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index d256fdeaa..4fb47bab6 100644 --- 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 \ No newline at end of file diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 5a3e99fcb..e2f1d630a 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1165,6 +1165,7 @@ BreadcrumbUser: User BreadcrumbStatic: Static resource BreadcrumbFavicon: Favicon BreadcrumbRobots: robots.txt +BreadcrumbMetrics: Metrics BreadcrumbLecturerInvite: Invitation to be a course administrator BreadcrumbExamOfficeUserInvite: Invitation regarding exam achievements BreadcrumbFunctionaryInvite: Invitation to be a department functionary @@ -1194,6 +1195,8 @@ BreadcrumbApplicationFiles: Application files BreadcrumbCourseNewsArchive: Archive BreadcrumbCourseNewsFile: File +TitleMetrics: Metrics + AuthPredsInfo: To view their own courses like a participant would, administrators and correctors can deactivate the checking of their credentials temporarily. Disabled authorisation predicates always fail. This means that deactivated predicates are not checked to grant access where it would otherwise not be permitted. These settings are only temporary, until your session expires i.e. your browser-cookie does. By deactivating predicates you can lock yourself out temporarily, at most. AuthPredsActive: Active authorisation predicates AuthPredsActiveChanged: Authorisation settings saved for the current session @@ -2125,3 +2128,7 @@ CommCourse: Course message CommTutorial: Tutorial message Clone: Cloning Deficit: Deficit + +MetricNoSamples: No samples +MetricName: Name +MetricValue: Value \ No newline at end of file diff --git a/models/users.model b/models/users.model index 57ae421cf..55ee044db 100644 --- 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 + \ No newline at end of file diff --git a/package-lock.json b/package-lock.json index b8f4e0d05..a5d734d8f 100644 --- 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": { diff --git a/package.json b/package.json index f3e14cd69..603a648a8 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.23.1", + "version": "7.25.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 594542815..c5339dc30 100644 --- 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: diff --git a/routes b/routes index af3ba9fc1..469ec0297 100644 --- a/routes +++ b/routes @@ -40,7 +40,8 @@ /auth AuthR Auth getAuth !free /favicon.ico FaviconR GET !free -/robots.txt RobotsR GET !free +/robots.txt RobotsR GET !free +/metrics MetricsR GET / HomeR GET !free /users UsersR GET POST -- no tags, i.e. admins only diff --git a/src/Application.hs b/src/Application.hs index 41ca6fed4..2da92e313 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -22,6 +22,8 @@ import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, import Import hiding (cancel) import Language.Haskell.TH.Syntax (qLocation) import Network.Wai (Middleware) +import qualified Network.Wai as Wai +import qualified Network.HTTP.Types as HTTP import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, runSettings, runSettingsSocket, setHost, @@ -48,6 +50,7 @@ import System.Directory import Jobs import qualified Data.Text.Encoding as Text + import Yesod.Auth.Util.PasswordStore import qualified Data.ByteString.Lazy as LBS @@ -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 diff --git a/src/Cron.hs b/src/Cron.hs index fe78ac694..36a063321 100644 --- 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 diff --git a/src/Data/Universe/Instances/Reverse/WithIndex.hs b/src/Data/Universe/Instances/Reverse/WithIndex.hs new file mode 100644 index 000000000..ff6550058 --- /dev/null +++ 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 ] diff --git a/src/Foundation.hs b/src/Foundation.hs index 2470d2088..688793330 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -8,6 +8,7 @@ module Foundation import Foundation.Type as Foundation import Foundation.I18n as Foundation +import Foundation.Routes as Foundation import Import.NoFoundation hiding (embedFile) @@ -107,7 +108,7 @@ import UnliftIO.Pool -- This function also generates the following type synonyms: -- type Handler x = HandlerT UniWorX IO x -- type Widget = WidgetT UniWorX IO () -mkYesodData "UniWorX" $(parseRoutesFile "routes") +mkYesodData "UniWorX" uniworxRoutes deriving instance Generic CourseR deriving instance Generic SheetR @@ -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 diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs new file mode 100644 index 000000000..614bdea6d --- /dev/null +++ b/src/Foundation/Routes.hs @@ -0,0 +1,10 @@ +module Foundation.Routes + ( uniworxRoutes + ) where + +import ClassyPrelude.Yesod +import Yesod.Routes.TH.Types (ResourceTree) + + +uniworxRoutes :: [ResourceTree String] +uniworxRoutes = $(parseRoutesFile "routes") diff --git a/src/Handler/Common.hs b/src/Handler/Common.hs index f11a76cfb..da1330be9 100644 --- a/src/Handler/Common.hs +++ b/src/Handler/Common.hs @@ -1,5 +1,8 @@ -- | Common handler functions. -module Handler.Common where +module Handler.Common + ( getFaviconR + , getRobotsR + ) where import Data.FileEmbed (embedFile) import Import hiding (embedFile) diff --git a/src/Handler/Course/LecturerInvite.hs b/src/Handler/Course/LecturerInvite.hs index 753bd7c10..44b27ce64 100644 --- 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 diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 6e2baca9d..280a69d6f 100644 --- 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 diff --git a/src/Handler/Exam/CorrectorInvite.hs b/src/Handler/Exam/CorrectorInvite.hs index 8314a8ca1..d207ff9ef 100644 --- 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, ()) diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index 8a157f72d..cfd109f94 100644 --- 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 diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs index 0a5d3b9bd..3e688c936 100644 --- 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 diff --git a/src/Handler/Metrics.hs b/src/Handler/Metrics.hs new file mode 100644 index 000000000..b51d8ebe9 --- /dev/null +++ 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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 661744614..bc5c308d4 100644 --- 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, ()) diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index d132683b1..9f3fe2788 100644 --- 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 diff --git a/src/Handler/Tutorial/TutorInvite.hs b/src/Handler/Tutorial/TutorInvite.hs index 1c1f119db..e78953b67 100644 --- 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, ()) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index e11f6a557..c2d944690 100644 --- 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 diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index 7780709a1..c4230890b 100644 --- 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 diff --git a/src/Handler/Utils/Routes.hs b/src/Handler/Utils/Routes.hs new file mode 100644 index 000000000..52a93dfed --- /dev/null +++ b/src/Handler/Utils/Routes.hs @@ -0,0 +1,11 @@ +module Handler.Utils.Routes + ( classifyHandler + ) where + +import Import + +import Utils.TH.Routes + + +classifyHandler :: Route UniWorX -> String +classifyHandler = $(classifyHandler' uniworxRoutes) diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 13d03d064..a49652b60 100644 --- 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) diff --git a/src/Jobs.hs b/src/Jobs.hs index 98ebf0209..88e66b146 100644 --- 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 diff --git a/src/Jobs/Handler/ChangeUserDisplayEmail.hs b/src/Jobs/Handler/ChangeUserDisplayEmail.hs index dd5e8f0d4..bbf62d0c1 100644 --- 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 diff --git a/src/Jobs/Handler/SendNotification/Utils.hs b/src/Jobs/Handler/SendNotification/Utils.hs index 49671e02d..111b43382 100644 --- 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)]) diff --git a/src/Jobs/Handler/SendPasswordReset.hs b/src/Jobs/Handler/SendPasswordReset.hs index d9acc739b..c589c3896 100644 --- 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 diff --git a/src/Model/Tokens.hs b/src/Model/Tokens.hs index 2b445eb99..5a2d6335e 100644 --- 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" diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 66a01cf6b..a1df33f56 100644 --- 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 diff --git a/src/Model/Types/TH/PathPiece.hs b/src/Model/Types/TH/PathPiece.hs index 365ffb969..daf1dd789 100644 --- 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|]) [] ] ] ] diff --git a/src/Prometheus/Instances.hs b/src/Prometheus/Instances.hs new file mode 100644 index 000000000..ba217324b --- /dev/null +++ b/src/Prometheus/Instances.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Prometheus.Instances + () where + +import ClassyPrelude +import Prometheus +import Data.Aeson + +import qualified Data.Map.Strict as Map + + +instance ToJSON SampleType where + toJSON = String . tshow + +instance ToJSON SampleGroup where + toJSON (SampleGroup Info{..} sgType samples) = object + [ "name" .= metricName + , "help" .= metricHelp + , "type" .= sgType + , "metrics" .= samples + ] + +instance ToJSON Sample where + toJSON (Sample sName sLabels sValue) = object + [ "name" .= sName + , "labels" .= Map.fromList sLabels + , "value" .= decodeUtf8 sValue + ] diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index 9726b5222..97805b159 100644 --- 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{..} diff --git a/src/Utils/TH/Routes.hs b/src/Utils/TH/Routes.hs new file mode 100644 index 000000000..18f8a7805 --- /dev/null +++ b/src/Utils/TH/Routes.hs @@ -0,0 +1,25 @@ +module Utils.TH.Routes + ( classifyHandler' + ) where + +import ClassyPrelude +import Yesod.Routes.TH.Types (ResourceTree, FlatResource(..), Piece(..), Dispatch(..), flatten) + +import Language.Haskell.TH + + +classifyHandler' :: [ResourceTree String] -> ExpQ +classifyHandler' = lamCaseE . map toMatch . flatten + where + toMatch FlatResource{..} = match (toPattern frDispatch $ frParentPieces ++ [(frName, frPieces)]) (normalB . litE $ stringL frName) [] + toPattern _ [] = error "Empty hierarchy in toPattern" + toPattern dp [(mkName -> con, dynPieces -> pieces)] = conP con $ replicate pieces wildP ++ dispatchPattern dp + toPattern dp ( (mkName -> con, dynPieces -> pieces) : xs) = conP con $ replicate pieces wildP ++ [ toPattern dp xs ] + dispatchPattern (Methods Nothing _) = [] + dispatchPattern (Methods (Just _) _) = [wildP] + dispatchPattern (Subsite _ _) = [wildP] + + dynPieces = length . mapMaybe onlyDyn + where + onlyDyn (Static _) = Nothing + onlyDyn p@(Dynamic _) = Just p diff --git a/src/Utils/Tokens.hs b/src/Utils/Tokens.hs index 64d4c0989..549ea81e6 100644 --- 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 diff --git a/stack.yaml b/stack.yaml index f83be73a7..a5abb45dd 100644 --- a/stack.yaml +++ b/stack.yaml @@ -60,5 +60,8 @@ extra-deps: - generic-lens-1.2.0.0 + - prometheus-metrics-ghc-1.0.0 + - wai-middleware-prometheus-1.0.0 + resolver: lts-13.21 allow-newer: true diff --git a/start.sh b/start.sh index 40da9eb05..49f9e79f3 100755 --- 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} diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index b6fc07906..11355082b 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -558,7 +558,7 @@ ul.list--inline { @media (min-width: 768px) { .deflist { - grid-template-columns: max-content minmax(0, max-content); + grid-template-columns: fit-content(25vw) 1fr; .deflist { margin-top: -10px; diff --git a/templates/metrics.hamlet b/templates/metrics.hamlet new file mode 100644 index 000000000..1881382bc --- /dev/null +++ b/templates/metrics.hamlet @@ -0,0 +1,46 @@ +$newline never +$maybe t <- metricsToken +
+ 
+      #{toPathPiece t}
+

+  

+    $forall SampleGroup Info{..} _ mSamples <- samples
+      

+        
#{metricName}
+        

+          #{metricHelp}
+      

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

+                #{decodeUtf8 sValue}
+              $case lPairs
+                $of []
+                $of _
+                  
    
+                    $forall (lName, lValue) <- lPairs
+                      
  • #{lName}=#{lValue}
+            $nothing
+              $with allLabels <- getLabels mSamples
+                
+                  
+                    
+                      
+                    $forall Sample sName lPairs sValue <- mSamples
+                      
+                        
    _{MsgMetricName}
+                      $forall l <- allLabels
+                        #{l}
+                      _{MsgMetricValue}
+                  
    
+                          #{metricBasename metricName sName}
+                        $forall l <- allLabels
+                          
+                            $maybe lValue <- lookup l lPairs
+                              #{lValue}
+                        
+                          #{decodeUtf8 sValue}