From b9181de1540f3e6b8f39c8cf8597dfc1fbecbf66 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 10 Aug 2020 15:41:19 +0200 Subject: [PATCH 1/8] chore: bump to ghc-8.10 --- load/Load.hs | 2 +- package.yaml | 7 +- src/Application.hs | 3 + src/Data/CaseInsensitive/Instances.hs | 4 +- src/Foundation.hs | 28 +- src/Handler/Course/Edit.hs | 2 +- src/Handler/Course/News/Edit.hs | 2 +- src/Handler/Course/ParticipantInvite.hs | 2 +- src/Handler/Course/Register.hs | 2 +- src/Handler/Course/User.hs | 2 +- src/Handler/Exam/Correct.hs | 2 +- src/Handler/Exam/List.hs | 5 +- src/Handler/Exam/Register.hs | 14 +- src/Handler/Sheet/List.hs | 2 +- src/Handler/Submission/List.hs | 6 +- src/Handler/Tutorial/List.hs | 2 +- src/Handler/Tutorial/New.hs | 2 +- src/Handler/Utils/Exam.hs | 2 +- src/Handler/Utils/Form.hs | 6 +- src/Handler/Utils/Rating.hs | 4 +- src/Handler/Utils/Submission.hs | 2 +- src/Handler/Utils/Table/Pagination.hs | 2 +- src/Jobs/Crontab.hs | 6 +- .../SendNotification/SubmissionEdited.hs | 4 +- src/Jobs/Handler/SynchroniseLdap.hs | 2 +- src/Settings.hs | 2 +- src/Utils.hs | 8 +- src/Utils/TH.hs | 8 +- .../Backend/Persistent/Memcached.hs | 2 +- src/Yesod/Core/Types/Instances.hs | 4 +- stack.yaml | 153 +++++---- stack.yaml.lock | 301 ++++++++++-------- test/Database/Fill.hs | 2 +- 33 files changed, 317 insertions(+), 278 deletions(-) diff --git a/load/Load.hs b/load/Load.hs index c168796c1..7c0020ca4 100644 --- a/load/Load.hs +++ b/load/Load.hs @@ -96,7 +96,7 @@ sampleIntegral = sampleN scaleIntegral instance PathPiece DiffTime where - toPathPiece = toPathPiece . MkFixed @E12 . diffTimeToPicoseconds + toPathPiece = (toPathPiece :: Pico -> Text) . MkFixed . diffTimeToPicoseconds fromPathPiece t = fromPathPiece t <&> \(MkFixed ps :: Pico) -> picosecondsToDiffTime ps diff --git a/package.yaml b/package.yaml index 182eddbf9..3d326017f 100644 --- a/package.yaml +++ b/package.yaml @@ -252,7 +252,7 @@ executables: uniworx: main: main.hs source-dirs: app - ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T" + ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T -xn" dependencies: - uniworx when: @@ -277,7 +277,7 @@ executables: ghc-options: - -main-is Load - -threaded - - -rtsopts "-with-rtsopts=-N -T" + - -rtsopts "-with-rtsopts=-N -T -xn" source-dirs: load dependencies: - uniworx @@ -311,8 +311,7 @@ tests: ghc-options: - -fno-warn-orphans - -threaded - - -rtsopts - - -with-rtsopts=-N + - -rtsopts "-with-rtsopts=-N -xn" hlint: main: Hlint.hs other-modules: [] diff --git a/src/Application.hs b/src/Application.hs index 65bdf4ea1..12c92bdeb 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -101,6 +101,8 @@ import qualified Network.Minio as Minio import Web.ServerSession.Core (StorageException(..)) +import GHC.RTS.Flags (getRTSFlags) + -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.News @@ -200,6 +202,7 @@ makeFoundation appSettings'@AppSettings{..} = do runAppLoggingT tempFoundation $ do $logInfoS "InstanceID" $ UUID.toText appInstanceID $logDebugS "Configuration" $ tshow appSettings' + $logDebugS "RTSFlags" . tshow =<< liftIO getRTSFlags smtpPool <- for appSmtpConf $ \c -> do $logDebugS "setup" "SMTP-Pool" diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index 6596fe47e..2b374fe63 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -77,8 +77,8 @@ instance ToWidget site a => ToWidget site (CI a) where instance RenderMessage site a => RenderMessage site (CI a) where renderMessage f ls msg = renderMessage f ls $ CI.original msg -instance Lift t => Lift (CI t) where - lift (CI.original -> orig) = [e|CI.mk $(lift orig)|] +instance (CI.FoldCase t, Lift t) => Lift (CI t) where + liftTyped (CI.original -> orig) = [||CI.mk $$(liftTyped orig)||] instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where diff --git a/src/Foundation.hs b/src/Foundation.hs index bc2317469..c2809cab3 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -719,20 +719,6 @@ tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route o return Authorized r -> $unsupportedAuthPredicate AuthSubmissionGroup r tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of - CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do - course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course - allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation - - case allocation of - Nothing -> return () - Just Allocation{..} -> do - cTime <- liftIO getCurrentTime - guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime) - guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo - - return Authorized - CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn @@ -2111,7 +2097,7 @@ siteLayout' headingOverride widget = do -> let route = navRoute' ident = navIdent in $(widgetFile "widgets/navbar/item") - NavPageActionPrimary{ navLink = navLink@NavLink{..}, .. } + NavPageActionPrimary{ navLink = navLink@NavLink{..} } -> let pWidget | NavTypeLink{..} <- navType , navModal @@ -2130,7 +2116,7 @@ siteLayout' headingOverride widget = do sWidgets = navChildren' & map (\(l, i, r) -> navWidget (NavPageActionSecondary l, i, Just r, [])) in $(widgetFile "widgets/pageaction/primary-wrapper") - NavPageActionSecondary{ navLink = navLink@NavLink{..}, .. } + NavPageActionSecondary{ navLink = navLink@NavLink{..} } | NavTypeLink{..} <- navType , navModal -> customModal Modal @@ -4535,25 +4521,25 @@ routeNormalizers = return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand ncSheet = maybeOrig $ \route -> do CSheetR tid ssh csh shn _ <- return route - Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh + cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn caseChanged shn sheetName return $ route & typesUsing @RouteChildren @SheetName . filtered (== shn) .~ sheetName ncMaterial = maybeOrig $ \route -> do CMaterialR tid ssh csh mnm _ <- return route - Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh + cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity _ Material{..} <- MaybeT . $cachedHereBinary (cid, mnm) . lift . getBy $ UniqueMaterial cid mnm caseChanged mnm materialName return $ route & typesUsing @RouteChildren @MaterialName . filtered (== mnm) .~ materialName ncTutorial = maybeOrig $ \route -> do CTutorialR tid ssh csh tutn _ <- return route - Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh + cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity _ Tutorial{..} <- MaybeT . $cachedHereBinary (cid, tutn) . lift . getBy $ UniqueTutorial cid tutn caseChanged tutn tutorialName return $ route & typesUsing @RouteChildren @TutorialName . filtered (== tutn) .~ tutorialName ncExam = maybeOrig $ \route -> do CExamR tid ssh csh examn _ <- return route - Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh + cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity _ Exam{..} <- MaybeT . $cachedHereBinary (cid, examn) . lift . getBy $ UniqueExam cid examn caseChanged examn examName return $ route & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ examName @@ -5095,7 +5081,7 @@ instance YesodAuth UniWorX where _other -> return res $logDebugS "auth" $ tshow Creds{..} - UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod + UniWorX{..} <- getYesod flip catches excHandlers $ case appLdapPool of Just ldapPool diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 03d867a6b..8ba44473e 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -539,7 +539,7 @@ courseEditHandler miButtonAction mbCourseForm = do upsertAllocationCourse :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m () upsertAllocationCourse cid cfAllocation = do now <- liftIO getCurrentTime - Course{..} <- getJust cid + Course{} <- getJust cid prevAllocationCourse <- getBy $ UniqueAllocationCourse cid prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse userAdmin <- fromMaybe False <$> for prevAllocation (\Allocation{..} -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR) diff --git a/src/Handler/Course/News/Edit.hs b/src/Handler/Course/News/Edit.hs index d982e890e..14c30f7b2 100644 --- a/src/Handler/Course/News/Edit.hs +++ b/src/Handler/Course/News/Edit.hs @@ -33,7 +33,7 @@ postCNEditR tid ssh csh cID = do , courseNewsSummary = cnfSummary , courseNewsLastEdit = now } - let mkFilter CourseNewsFileResidual{..} = [ CourseNewsFileNews ==. nId ] + let mkFilter CourseNewsFileResidual{} = [ CourseNewsFileNews ==. nId ] in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ traverse_ id cnfFiles addMessageI Success MsgCourseNewsEdited redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|] diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 61a4316f9..f461816b8 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -92,7 +92,7 @@ participantInvitationConfig = InvitationConfig{..} itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do + invitationForm _ _ uid = hoistAForm lift . wFormToAForm $ do now <- liftIO getCurrentTime studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index 66b9b3566..139af8444 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -263,7 +263,7 @@ deregisterParticipant :: UserId -> CourseId -> DB () deregisterParticipant uid cid = do deleteApplications uid cid part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid - forM_ part $ \(Entity partId CourseParticipant{..}) -> do + forM_ part $ \(Entity partId CourseParticipant{}) -> do update partId [CourseParticipantState =. CourseParticipantInactive False] audit $ TransactionCourseParticipantDeleted cid uid diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index a23a8128e..690d02099 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -115,7 +115,7 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = , formSubmit = FormAutoSubmit , formAnchor = Just registrationFieldFrag } - for_ mRegistration $ \(Entity pId CourseParticipant{..}) -> + for_ mRegistration $ \(Entity pId CourseParticipant{}) -> formResult regFieldRes $ \courseParticipantField' -> do lift . runDB $ do update pId [ CourseParticipantField =. courseParticipantField' ] diff --git a/src/Handler/Exam/Correct.hs b/src/Handler/Exam/Correct.hs index 895d72d86..7e85169c9 100644 --- a/src/Handler/Exam/Correct.hs +++ b/src/Handler/Exam/Correct.hs @@ -113,7 +113,7 @@ postECorrectR tid ssh csh examn = do mayEditResults <- hasWriteAccessTo $ CExamR tid ssh csh examn EUsersR response <- runDB . exceptT (<$ transactionUndo) return $ do - Entity eId Exam{..} <- lift $ fetchExam tid ssh csh examn + Entity eId Exam{} <- lift $ fetchExam tid ssh csh examn euid <- traverse decrypt ciqUser guardMExceptT (maybe True ((>= 3) . length) $ euid ^? _Left) $ diff --git a/src/Handler/Exam/List.hs b/src/Handler/Exam/List.hs index 6b4dae091..45c670559 100644 --- a/src/Handler/Exam/List.hs +++ b/src/Handler/Exam/List.hs @@ -81,10 +81,9 @@ mkExamTable (Entity cid Course{..}) = do getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCExamListR tid ssh csh = do - (Entity _ Course{..}, examTable) <- runDB $ do + examTable <- runDB $ do c <- getBy404 $ TermSchoolCourseShort tid ssh csh - (_, examTable) <- mkExamTable c - return (c, examTable) + view _2 <$> mkExamTable c siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading diff --git a/src/Handler/Exam/Register.hs b/src/Handler/Exam/Register.hs index 744c76625..15e2a02eb 100644 --- a/src/Handler/Exam/Register.hs +++ b/src/Handler/Exam/Register.hs @@ -36,9 +36,9 @@ instance Button UniWorX ButtonExamRegister where postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html postERegisterR tid ssh csh examn = do - Entity uid User{..} <- requireAuth + uid <- requireAuthId - Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn + Entity eId Exam{} <- runDB $ fetchExam tid ssh csh examn ((btnResult, _), _) <- runFormPost $ buttonForm' [BtnExamRegister, BtnExamDeregister] @@ -63,11 +63,11 @@ postERegisterR tid ssh csh examn = do postERegisterOccR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> ExamOccurrenceName -> Handler Html postERegisterOccR tid ssh csh examn occn = do - Entity uid User{..} <- requireAuth - (Entity eId Exam{..}, Entity occId ExamOccurrence{..}) <- runDB $ do - eexam@(Entity eId _) <- fetchExam tid ssh csh examn - occ <- getBy404 $ UniqueExamOccurrence eId occn - return (eexam, occ) + uid <- requireAuthId + (eId, occId) <- runDB $ do + Entity eId _ <- fetchExam tid ssh csh examn + occ <- getKeyBy404 $ UniqueExamOccurrence eId occn + return (eId, occ) ((btnResult, _), _) <- runFormPost buttonForm diff --git a/src/Handler/Sheet/List.hs b/src/Handler/Sheet/List.hs index a4b7217ba..7421017df 100644 --- a/src/Handler/Sheet/List.hs +++ b/src/Handler/Sheet/List.hs @@ -69,7 +69,7 @@ getSheetListR tid ssh csh = do , sortable Nothing (i18nCell MsgSubmission) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub, _)} -> case mbSub of Nothing -> mempty - (Just (Entity sid Submission{..})) -> + (Just (Entity sid Submission{})) -> let mkCid = encrypt sid -- TODO: executed twice mkRoute = do cid' <- mkCid diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index 1f892a5bf..12544e87d 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -122,7 +122,7 @@ colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnad colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(_, _, _, _, _, _, cid, _) } -> return cid colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, course, _, _, users, _, hasAccess) } -> +colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, _, users, _, hasAccess) } -> let csh = course ^. _2 tid = course ^. _3 @@ -136,8 +136,8 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB | otherwise -> mempty colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, (_, csh, tid, ssh), _, _, users, _, hasAccess) } -> - let protoCell = listCell (Map.toList $ Map.mapMaybe (\x@(User{..}, _, _) -> (x,) <$> assertM (not . null) userMatrikelnummer) users) $ \(userId, ((User{..}, _, _), matr)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) matr +colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, (_, csh, tid, ssh), _, _, users, _, hasAccess) } -> + let protoCell = listCell (Map.toList $ Map.mapMaybe (\x@(User{userMatrikelnummer}, _, _) -> (x,) <$> assertM (not . null) userMatrikelnummer) users) $ \(userId, (_, matr)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) matr in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] | otherwise -> mempty diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs index 67094db9f..1a2a3ffb8 100644 --- a/src/Handler/Tutorial/List.hs +++ b/src/Handler/Tutorial/List.hs @@ -15,7 +15,7 @@ import qualified Data.CaseInsensitive as CI getCTutorialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCTutorialListR tid ssh csh = do - Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh + cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh MsgRenderer mr <- getMsgRenderer let diff --git a/src/Handler/Tutorial/New.hs b/src/Handler/Tutorial/New.hs index 0b80d6aec..0e6e65cfc 100644 --- a/src/Handler/Tutorial/New.hs +++ b/src/Handler/Tutorial/New.hs @@ -16,7 +16,7 @@ import Handler.Tutorial.TutorInvite getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCTutorialNewR = postCTutorialNewR postCTutorialNewR tid ssh csh = do - Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh + cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index cc8405762..e54f9c3f4 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -477,7 +477,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])] bestOption = case rule of ExamRoomSurname -> do - (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' lineNudges charCost + (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` (pack . toListOf (_1 . folded . to CI.foldedCase))) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' lineNudges charCost -- traceM $ show cost return res ExamRoomMatriculation -> do diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 0345765f8..cc5be1768 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -257,7 +257,7 @@ multiActionField :: forall action a. -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) -multiActionField minp acts (actField, actExternal, actMessage) fs@FieldSettings{..} defAction csrf = do +multiActionField minp acts (actField, actExternal, actMessage) fs defAction csrf = do (actionRes, actionView) <- minp (checkBool (`Map.member` acts) MsgMultiActionUnknownAction actField) fs defAction results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts @@ -285,7 +285,7 @@ multiActionOpts' :: forall action a. -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) -multiActionOpts' minp acts mActsOpts fs@FieldSettings{..} defAction csrf = do +multiActionOpts' minp acts mActsOpts fs defAction csrf = do actsOpts <- liftHandler mActsOpts let actsOpts' = OptionList { olOptions = filter (flip Map.member acts . optionInternalValue) $ olOptions actsOpts @@ -397,7 +397,7 @@ explainedMultiAction' :: forall action a. -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) -explainedMultiAction' minp acts mActsOpts fs@FieldSettings{..} defAction csrf = do +explainedMultiAction' minp acts mActsOpts fs defAction csrf = do (actsOpts, actsReadExternal) <- liftHandler mActsOpts let actsOpts' = filter (flip Map.member acts . optionInternalValue . view _1) actsOpts actsReadExternal' = assertM (flip Map.member acts) . actsReadExternal diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 8ba23b315..90d7d0375 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -31,7 +31,7 @@ import qualified Data.Char as Char validateRating :: SheetType -> Rating' -> [RatingValidityException] -validateRating ratingSheetType Rating'{ ratingPoints=Just rp, .. } +validateRating ratingSheetType Rating'{ ratingPoints=Just rp } | rp < 0 = [RatingNegative] | NotGraded <- ratingSheetType @@ -93,7 +93,7 @@ ratingFile :: ( MonadHandler m , HandlerSite m ~ UniWorX ) => CryptoFileNameSubmission -> Rating -> m File -ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do +ratingFile cID rating@Rating{ ratingValues = Rating'{..} } = do mr'@(MsgRenderer mr) <- getMsgRenderer dtFmt <- getDateTimeFormatter fileModified <- maybe (liftIO getCurrentTime) return ratingTime diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 8d0a895cc..e29f9ce50 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -320,7 +320,7 @@ submissionMultiArchive anonymous (Set.toList -> ids) = do respondSource typeZip . (<* lift cleanup) . transPipe (runDBRunner dbrunner) $ do let fileEntitySource' :: (Rating, Entity Submission, Maybe UTCTime, (SheetName,CourseShorthand,SchoolId,TermId,Bool)) -> ConduitT () File (YesodDB UniWorX) () - fileEntitySource' (rating, Entity submissionID Submission{..}, subTime, (shn,csh,ssh,tid,sheetAnonymous)) = do + fileEntitySource' (rating, Entity submissionID Submission{}, subTime, (shn,csh,ssh,tid,sheetAnonymous)) = do cID <- encrypt submissionID let diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 9a22aab88..872223892 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -450,7 +450,7 @@ instance Traversable DBRow where newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) } instance Default (PSValidator m x) where - def = PSValidator $ \DBTable{..} -> \case + def = PSValidator $ \DBTable{} -> \case Nothing -> def Just pi -> swap . (\act -> execRWS act pi def) $ do asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s }) diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 9dcb04933..2a801ff79 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -27,7 +27,7 @@ import qualified Database.Esqueleto as E determineCrontab :: DB (Crontab JobCtl) -- ^ Extract all future jobs from the database (sheet deadlines, ...) determineCrontab = execWriterT $ do - UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod + UniWorX{ appSettings' = AppSettings{..} } <- getYesod case appJobFlushInterval of Just interval -> tell $ HashMap.singleton @@ -343,7 +343,7 @@ determineCrontab = execWriterT $ do let - externalExamJobs (Entity nExternalExam ExternalExam{..}) = do + externalExamJobs nExternalExam = do newestResult <- lift . E.select . E.from $ \externalExamResult -> do E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. E.val nExternalExam return . E.max_ $ externalExamResult E.^. ExternalExamResultLastChanged @@ -360,7 +360,7 @@ determineCrontab = execWriterT $ do } _other -> return () - runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ externalExamJobs + runConduit $ transPipe lift (selectKeys [] []) .| C.mapM_ externalExamJobs let allocationJobs (Entity nAllocation Allocation{..}) = do diff --git a/src/Jobs/Handler/SendNotification/SubmissionEdited.hs b/src/Jobs/Handler/SendNotification/SubmissionEdited.hs index 6fc6c1ec3..9a3ccc316 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionEdited.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionEdited.hs @@ -20,7 +20,7 @@ import qualified Data.Text as Text dispatchNotificationSubmissionEdited :: UserId -> SubmissionId -> UserId -> Handler () dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient = userMailT jRecipient $ do - (Course{..}, Sheet{..}, Submission{..}, initiator, coSubmittors) <- liftHandler . runDB $ do + (Course{..}, Sheet{..}, Submission{}, initiator, coSubmittors) <- liftHandler . runDB $ do submission <- getJust nSubmission sheet <- belongsToJust submissionSheet submission course <- belongsToJust sheetCourse sheet @@ -55,7 +55,7 @@ dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient = userMai dispatchNotificationSubmissionUserCreated :: UserId -> SubmissionId -> UserId -> Handler () dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient = userMailT jRecipient $ do - (User{..}, Course{..}, Sheet{..}, Submission{..}, coSubmittors) <- liftHandler . runDB $ do + (User{..}, Course{..}, Sheet{..}, Submission{}, coSubmittors) <- liftHandler . runDB $ do submission <- getJust nSubmission sheet <- belongsToJust submissionSheet submission course <- belongsToJust sheetCourse sheet diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs index 26dcf2b82..14d5e6668 100644 --- a/src/Jobs/Handler/SynchroniseLdap.hs +++ b/src/Jobs/Handler/SynchroniseLdap.hs @@ -38,7 +38,7 @@ dispatchJobSynchroniseLdap numIterations epoch iteration dispatchJobSynchroniseLdapUser :: UserId -> JobHandler UniWorX dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do - UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod + UniWorX{..} <- getYesod case appLdapPool of Just ldapPool -> runDB . void . runMaybeT . handleExc $ do diff --git a/src/Settings.hs b/src/Settings.hs index 490d8076c..cd37a38c5 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -418,7 +418,7 @@ instance FromJSON AppSettings where Ldap.Plain host -> not $ null host appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= [] appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp" - let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}, ..} = and + let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}} = and [ not $ null connectHost , numConnection > 0 , connectionIdleTime >= 0 diff --git a/src/Utils.hs b/src/Utils.hs index 0baeee670..0b5670ad7 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -151,8 +151,8 @@ maybeAttribute a c (Just v) = [(a,c v)] newtype PrettyValue = PrettyValue { unPrettyValue :: Value } - deriving (Eq, Read, Show, Generic, Typeable, Data) - deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData) + deriving (Eq, Read, Show, Generic, Typeable, Data, TH.Lift) + deriving newtype (Hashable, IsString, FromJSON, ToJSON, NFData) instance ToContent PrettyValue where toContent = toContent . Builder.toLazyText . Aeson.encodePrettyToTextBuilder @@ -166,8 +166,8 @@ toPrettyJSON = PrettyValue . toJSON newtype YamlValue = YamlValue { unYamlValue :: Value } - deriving (Eq, Read, Show, Generic, Typeable, Data) - deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData) + deriving (Eq, Read, Show, Generic, Typeable, Data, TH.Lift) + deriving newtype (Hashable, IsString, FromJSON, ToJSON, NFData) instance ToContent YamlValue where toContent = toContent . Yaml.encode diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index 9855daeb6..b233aaa73 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -71,10 +71,10 @@ curryN :: Int -> ExpQ curryN n = do fn <- newName "foo" xs <- replicateM n $ newName "x" - let pat = map VarP (fn:xs) - let tup = TupE (map VarE xs) - let rhs = AppE (VarE fn) tup - return $ LamE pat rhs + let pat = map varP (fn:xs) + let tup = tupE (map varE xs) + let rhs = appE (varE fn) tup + lamE pat rhs uncurryN :: Int -> ExpQ uncurryN n = do diff --git a/src/Web/ServerSession/Backend/Persistent/Memcached.hs b/src/Web/ServerSession/Backend/Persistent/Memcached.hs index a10be734e..bdf4df53b 100644 --- a/src/Web/ServerSession/Backend/Persistent/Memcached.hs +++ b/src/Web/ServerSession/Backend/Persistent/Memcached.hs @@ -137,7 +137,7 @@ instance (IsSessionData sess, Binary (Decomposed sess)) => Storage (MemcachedSql deleteSession MemcachedSqlStorage{..} sessId = liftIO . handleIf Memcached.isKeyNotFound (const $ return ()) $ Memcached.delete (memcachedSqlSessionId # sessId) mcdSqlMemcached - deleteAllSessionsOfAuthId MemcachedSqlStorage{..} authId = do + deleteAllSessionsOfAuthId MemcachedSqlStorage{} authId = do now <- liftIO getCurrentTime void $ upsert ( MemcachedSessionExpiration authId now ) diff --git a/src/Yesod/Core/Types/Instances.hs b/src/Yesod/Core/Types/Instances.hs index 62ffbdb4c..e05f92f0d 100644 --- a/src/Yesod/Core/Types/Instances.hs +++ b/src/Yesod/Core/Types/Instances.hs @@ -57,6 +57,7 @@ newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT' :: ReaderT Loc m a } , MonadIO , MonadThrow, MonadCatch, MonadMask, MonadLogger, MonadLoggerIO , MonadResource, MonadHandler, MonadWidget + , MonadUnliftIO ) deriving newtype ( MFunctor, MMonad, MonadTrans ) @@ -67,9 +68,6 @@ instance MonadReader r m => MonadReader r (CachedMemoT k v m) where reader = CachedMemoT . lift . reader local f (CachedMemoT act) = CachedMemoT $ mapReaderT (local f) act -instance MonadUnliftIO m => MonadUnliftIO (CachedMemoT k v m) where - askUnliftIO = (\UnliftIO{..} -> UnliftIO $ \(CachedMemoT f) -> unliftIO f) <$> CachedMemoT askUnliftIO - -- | Uses `cachedBy` with a `Binary`-encoded @k@ instance (Typeable v, Binary k, MonadHandler m) => MonadMemo k v (CachedMemoT k v m) where diff --git a/stack.yaml b/stack.yaml index fc8dcaefa..14ba29f32 100644 --- a/stack.yaml +++ b/stack.yaml @@ -34,91 +34,124 @@ extra-deps: commit: f8170266ab25b533576e96715bedffc5aa4f19fa subdirs: - colonnade - - git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git - commit: 9a4e3889a93cf71d6bbf45b673f6353b39f15d9f + # - git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git + # commit: 9a4e3889a93cf71d6bbf45b673f6353b39f15d9f + - ../minio-hs - # - colonnade-1.2.0.2 - - hsass-0.8.0 - - hlibsass-0.1.8.1 - - tz-0.1.3.3 + # # - colonnade-1.2.0.2 + # - hsass-0.8.0 + # - hlibsass-0.1.8.1 + # - tz-0.1.3.3 - # - zip-stream-0.2.0.1 + # # - zip-stream-0.2.0.1 - - uuid-crypto-1.4.0.0 - - filepath-crypto-0.1.0.0 - - cryptoids-0.5.1.0 - - cryptoids-types-1.0.0 - - cryptoids-class-0.0.0 + # - uuid-crypto-1.4.0.0 + # - filepath-crypto-0.1.0.0 + # - cryptoids-0.5.1.0 + # - cryptoids-types-1.0.0 + # - cryptoids-class-0.0.0 - - system-locale-0.3.0.0 + # - system-locale-0.3.0.0 - - hlint-test-0.1.0.0 + # - hlint-test-0.1.0.0 - - pkcs7-1.0.0.1 + # - pkcs7-1.0.0.1 - - systemd-2.2.0 + # - systemd-2.2.0 - # - directory-1.3.4.0 + # # - directory-1.3.4.0 - # - HaXml-1.25.5 + # # - HaXml-1.25.5 - # - persistent-2.10.4 - # - persistent-postgresql-2.10.1 - # - persistent-template-2.7.3 - # - esqueleto-3.2.3 + # # - persistent-2.10.4 + # # - persistent-postgresql-2.10.1 + # # - persistent-template-2.7.3 + # # - esqueleto-3.2.3 - - sandi-0.5 - - storable-endian-0.2.6 - # - universe-1.2 - # - universe-base-1.1.1 - # - universe-reverse-instances-1.1 - # - unliftio-pool-0.2.1.0 - # - universe-instances-extended-1.1.1 - # - universe-some-1.2 - # - some-1.0.0.3 + # - sandi-0.5 + # - storable-endian-0.2.6 + # # - universe-1.2 + # # - universe-base-1.1.1 + # # - universe-reverse-instances-1.1 + # # - unliftio-pool-0.2.1.0 + # # - universe-instances-extended-1.1.1 + # # - universe-some-1.2 + # # - some-1.0.0.3 - # - network-bsd-2.8.1.0 + # # - network-bsd-2.8.1.0 - # - persistent-qq-2.9.1 + # # - persistent-qq-2.9.1 - # - process-1.6.5.1 + # # - process-1.6.5.1 - # - generic-lens-1.2.0.0 + # # - generic-lens-1.2.0.0 - - prometheus-metrics-ghc-1.0.1 - - wai-middleware-prometheus-1.0.0 + # - prometheus-metrics-ghc-1.0.1 + # - wai-middleware-prometheus-1.0.0 - # - extended-reals-0.2.3.0 + # # - extended-reals-0.2.3.0 - - pandoc-2.9.2 - - doclayout-0.3 - - doctemplates-0.8.1 - # - emojis-0.1 - # - hslua-module-system-0.2.1 - # - ipynb-0.1 - # - jira-wiki-markup-1.0.0 - # - HsYAML-0.2.1.0 - # - cmark-gfm-0.2.1 - # - haddock-library-1.8.0 - # - pandoc-types-1.20 - # - skylighting-0.8.3.2 - # - skylighting-core-0.8.3.2 - # - texmath-0.12.0.1 + # - pandoc-2.9.2 + # - doclayout-0.3 + # - doctemplates-0.8.1 + # # - emojis-0.1 + # # - hslua-module-system-0.2.1 + # # - ipynb-0.1 + # # - jira-wiki-markup-1.0.0 + # # - HsYAML-0.2.1.0 + # # - cmark-gfm-0.2.1 + # # - haddock-library-1.8.0 + # # - pandoc-types-1.20 + # # - skylighting-0.8.3.2 + # # - skylighting-core-0.8.3.2 + # # - texmath-0.12.0.1 - - binary-instances-1 + # - binary-instances-1 - - acid-state-0.16.0 + # - acid-state-0.16.0 - - unidecode-0.1.0.4 + # - unidecode-0.1.0.4 - - token-bucket-0.1.0.1 + # - token-bucket-0.1.0.1 - - normaldistribution-1.1.0.3 + # - normaldistribution-1.1.0.3 - - unordered-containers-0.2.11.0 + # - unordered-containers-0.2.11.0 - - base64-bytestring-1.1.0.0 + # - base64-bytestring-1.1.0.0 -resolver: lts-15.12 + - acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207 + - bytebuild-0.3.6.0@sha256:aec785c906db5c7ec730754683196eb99a0d48e0deff7d4034c7b58307040b85,2982 + - byteslice-0.2.3.0@sha256:3ebcc77f8ac9fec3ca1a8304e66cfe0a1590c9272b768f2b19637e06de00bf6d,2014 + - bytesmith-0.3.7.0@sha256:a11e4ca0fb72cd966c21d82dcc2eb7f3aa748b3fbfe30ab6c7fa8beea38c8e83,1863 + - commonmark-0.1.0.2@sha256:fbff7a2ade0ce7d699964a87f765e503a3a9e22542c05f0f02ba7aad64e38af4,3278 + - commonmark-extensions-0.2.0.1@sha256:647aa8dba5fd46984ddedc15c3693c9c4d9655503d42006576bd8f0dadf8cd39,3176 + - commonmark-pandoc-0.2.0.0@sha256:84a9f6846d4fe33e9f0dcd938ef1c83162fb4fe81cca66315249e86414aac226,1167 + - contiguous-0.5.1@sha256:902b74d8e369fef384c20b116c3c81e65eca2672d79f525ab374fe98ee50e9d4,1757 + - cryptoids-0.5.1.0@sha256:729cd89059c6b6a50e07b2e279f6d95ee9432caeedc7e2f38f71e59c422957bc,1570 + - cryptoids-class-0.0.0@sha256:8d22912538faa99849fed7f51eb742fbbf5f9557d04e1d81bcac408d88c16c30,985 + - cryptoids-types-1.0.0@sha256:96a74b33a32ebeebf5bee08e2a205e5c1585b4b46b8bac086ca7fde49aec5f5b,1271 + - filepath-crypto-0.1.0.0@sha256:e02bc15858cf06edf9788a38b5b58d45e82c7f5589785a178a903d792af04125,1593 + - hlibsass-0.1.10.1@sha256:08db56c633e9a83a642d8ea57dffa93112b092d05bf8f3b07491cfee9ee0dfa5,2565 + - hsass-0.8.0@sha256:05fb3d435dbdf9f66a98db4e1ee57a313170a677e52ab3a5a05ced1fc42b0834,2899 + - ip-1.7.2@sha256:2148bbc7b5e66ea7273b6014bb30483cc656b2cd4e53efaf165c2223bdbbeb46,3742 + - natural-arithmetic-0.1.2.0@sha256:ac25a0561c8378530a62f02df83680afb193ed1059bb43e3130e0074b5b3f16b,3411 + - normaldistribution-1.1.0.3@sha256:2615b784c4112cbf6ffa0e2b55b76790290a9b9dff18a05d8c89aa374b213477,2160 + - pandoc-2.10.1@sha256:23d7ec480c7cb86740475a419d6ca4819987b6dd23bbae9b50bc3d42a7ed2f9f,36933 + - pkcs7-1.0.0.1@sha256:b26e5181868667abbde3ce17f9a61cf705eb695da073cdf82e1f9dfd6cc11176,3594 + - primitive-offset-0.2.0.0@sha256:f8006927d5c0a3e83707610bbc5514aabe8f84a907ecb07edd2c815f58299dea,843 + - primitive-unlifted-0.1.3.0@sha256:a98f827740f5dcf097d885b3a47c32f4462204449620abc9d51b8c4f8619f9e6,1427 + - prometheus-metrics-ghc-1.0.1.1@sha256:d378a7186a967140fe0e09d325fe5e3bfd7b77a1123934b40f81fdfed2eacbdc,1233 + - run-st-0.1.1.0@sha256:a43245bb23984089016772481bf52bfe63eaff0c5040303f69c9b15e80872fdc,883 + - sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 + - system-locale-0.3.0.0@sha256:13b3982403d8ac8cc6138e68802be8d8e7cf7ebc4cbc7e47e99e3c0dd1be066a,1529 + - token-bucket-0.1.0.1@sha256:d8e85f2fc373939975e7ace7907baee177531ab6e43df94e330a2357e64a2d11,1899 + - tuples-0.1.0.0@sha256:7006c1cab721ad3e39cdbf1ccb07ec050b94d654cc6e39277d46241eee6ac7c9,1088 + - tz-0.1.3.4@sha256:bd311e202b8bdd15bcd6a4ca182e69794949d3b3b9f4aa835e9ccff011284979,5086 + - unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144 + - uuid-crypto-1.4.0.0@sha256:9e2f271e61467d9ea03e78cddad75a97075d8f5108c36a28d59c65abb3efd290,1325 + - wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314 + +resolver: nightly-2020-08-08 allow-newer: true diff --git a/stack.yaml.lock b/stack.yaml.lock index 2219201a5..398eecca6 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -151,204 +151,225 @@ packages: git: git@gitlab2.rz.ifi.lmu.de:uni2work/colonnade.git commit: f8170266ab25b533576e96715bedffc5aa4f19fa - completed: - cabal-file: - size: 9845 - sha256: 674630347209bc5f7984e8e9d93293510489921f2d2d6092ad1c9b8c61b6560a - name: minio-hs - version: 1.5.2 - git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git + hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207 pantry-tree: - size: 4517 - sha256: ef7c5960da571c6cb41337b0bd30740bac92b4781b375be704093fdadd17330d - commit: 9a4e3889a93cf71d6bbf45b673f6353b39f15d9f + size: 13678 + sha256: d57bcb2ad5e01fe7424abbcf9e58cf943027b5c4a8496d93625c57b6e1272274 original: - git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git - commit: 9a4e3889a93cf71d6bbf45b673f6353b39f15d9f + hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207 - completed: - hackage: hsass-0.8.0@sha256:82d55fb2a10342accbc4fe80d263163f40a138d8636e275aa31ffa81b14abf01,2792 + hackage: bytebuild-0.3.6.0@sha256:aec785c906db5c7ec730754683196eb99a0d48e0deff7d4034c7b58307040b85,2982 pantry-tree: - size: 1448 - sha256: dc39ed0207b8b22d2713054421dbd5452baa9704df75bedf17f04f97a29f3d9a + size: 844 + sha256: 5e6fd3de57a4d44257fb475433633939459e0294fafe79b21ff67aeb93a81591 original: - hackage: hsass-0.8.0 + hackage: bytebuild-0.3.6.0@sha256:aec785c906db5c7ec730754683196eb99a0d48e0deff7d4034c7b58307040b85,2982 - completed: - hackage: hlibsass-0.1.8.1@sha256:7005d0f3fee66e776300117f6bf31583bf310f58df6d7f552c8811bd406abfc8,2564 + hackage: byteslice-0.2.3.0@sha256:3ebcc77f8ac9fec3ca1a8304e66cfe0a1590c9272b768f2b19637e06de00bf6d,2014 pantry-tree: - size: 8441 - sha256: c3c1fe56c35eed093772b9900d7038287b829d67960c6f96a82c9dc46b203db0 + size: 1095 + sha256: 9ada4e1c418e8d9029edefdf664c64ff419ed1f02564e5a0dd28dd03e1e716a6 original: - hackage: hlibsass-0.1.8.1 + hackage: byteslice-0.2.3.0@sha256:3ebcc77f8ac9fec3ca1a8304e66cfe0a1590c9272b768f2b19637e06de00bf6d,2014 - completed: - hackage: tz-0.1.3.3@sha256:b9de0c1b10825460ff14a237209a8bf7747f47979601d35621276556bf63d2ca,5086 + hackage: bytesmith-0.3.7.0@sha256:a11e4ca0fb72cd966c21d82dcc2eb7f3aa748b3fbfe30ab6c7fa8beea38c8e83,1863 pantry-tree: - size: 1180 - sha256: ae6af45f3dba5a478ea9cc77c718f955fcc5c96f2dc0f4ede34c4a15a3e85ac1 + size: 1185 + sha256: 3396c1b29577cff2491382d0b144fe586c75987e9ad28bc0cadbc88a97ee7315 original: - hackage: tz-0.1.3.3 + hackage: bytesmith-0.3.7.0@sha256:a11e4ca0fb72cd966c21d82dcc2eb7f3aa748b3fbfe30ab6c7fa8beea38c8e83,1863 - completed: - hackage: uuid-crypto-1.4.0.0@sha256:9e2f271e61467d9ea03e78cddad75a97075d8f5108c36a28d59c65abb3efd290,1325 + hackage: commonmark-0.1.0.2@sha256:fbff7a2ade0ce7d699964a87f765e503a3a9e22542c05f0f02ba7aad64e38af4,3278 pantry-tree: - size: 364 - sha256: 6650b51ea060397c412b07b256c043546913292973284a7149ddd08f489b3e48 + size: 1346 + sha256: 991da6da60804286b9ea23a1522e18ceeabddfdf416787231db9fd047c163f53 original: - hackage: uuid-crypto-1.4.0.0 + hackage: commonmark-0.1.0.2@sha256:fbff7a2ade0ce7d699964a87f765e503a3a9e22542c05f0f02ba7aad64e38af4,3278 - completed: - hackage: filepath-crypto-0.1.0.0@sha256:e02bc15858cf06edf9788a38b5b58d45e82c7f5589785a178a903d792af04125,1593 + hackage: commonmark-extensions-0.2.0.1@sha256:647aa8dba5fd46984ddedc15c3693c9c4d9655503d42006576bd8f0dadf8cd39,3176 pantry-tree: - size: 623 - sha256: bce236365ebdc6e5c46f740876a6fb5ad688e8ee3b305933822ab027e5b5fd86 + size: 2927 + sha256: 89e1ee05938d558834c397a3a22cdacc755a1941c144f4c1f3daf8a1ede943ce original: - hackage: filepath-crypto-0.1.0.0 + hackage: commonmark-extensions-0.2.0.1@sha256:647aa8dba5fd46984ddedc15c3693c9c4d9655503d42006576bd8f0dadf8cd39,3176 +- completed: + hackage: commonmark-pandoc-0.2.0.0@sha256:84a9f6846d4fe33e9f0dcd938ef1c83162fb4fe81cca66315249e86414aac226,1167 + pantry-tree: + size: 326 + sha256: aa88fb10bd382b8d942b51b2ad0b94f52a72a4e37c8085abc5c380964c7eeb7c + original: + hackage: commonmark-pandoc-0.2.0.0@sha256:84a9f6846d4fe33e9f0dcd938ef1c83162fb4fe81cca66315249e86414aac226,1167 +- completed: + hackage: contiguous-0.5.1@sha256:902b74d8e369fef384c20b116c3c81e65eca2672d79f525ab374fe98ee50e9d4,1757 + pantry-tree: + size: 442 + sha256: 39ee8ba3b4725ed1057429cd1f613275bfecbc618f289559203bebb1ff4a259e + original: + hackage: contiguous-0.5.1@sha256:902b74d8e369fef384c20b116c3c81e65eca2672d79f525ab374fe98ee50e9d4,1757 - completed: hackage: cryptoids-0.5.1.0@sha256:729cd89059c6b6a50e07b2e279f6d95ee9432caeedc7e2f38f71e59c422957bc,1570 pantry-tree: size: 513 sha256: 563e8d2b616ec3e0e7984d6b069095b6c3959065c0bb047fc8dd5809711a3e6b original: - hackage: cryptoids-0.5.1.0 -- completed: - hackage: cryptoids-types-1.0.0@sha256:96a74b33a32ebeebf5bee08e2a205e5c1585b4b46b8bac086ca7fde49aec5f5b,1271 - pantry-tree: - size: 268 - sha256: 0e9b11f6414a0a179cd11dec55261a1f9995663fcf27bfd4a386c48652655404 - original: - hackage: cryptoids-types-1.0.0 + hackage: cryptoids-0.5.1.0@sha256:729cd89059c6b6a50e07b2e279f6d95ee9432caeedc7e2f38f71e59c422957bc,1570 - completed: hackage: cryptoids-class-0.0.0@sha256:8d22912538faa99849fed7f51eb742fbbf5f9557d04e1d81bcac408d88c16c30,985 pantry-tree: size: 359 sha256: 6a5af7c785c230501fa6088ecf963c7de7463ab75b3f646510612f17dff69744 original: - hackage: cryptoids-class-0.0.0 + hackage: cryptoids-class-0.0.0@sha256:8d22912538faa99849fed7f51eb742fbbf5f9557d04e1d81bcac408d88c16c30,985 - completed: - hackage: system-locale-0.3.0.0@sha256:13b3982403d8ac8cc6138e68802be8d8e7cf7ebc4cbc7e47e99e3c0dd1be066a,1529 + hackage: cryptoids-types-1.0.0@sha256:96a74b33a32ebeebf5bee08e2a205e5c1585b4b46b8bac086ca7fde49aec5f5b,1271 pantry-tree: - size: 446 - sha256: 3b22af3e6315835bf614a0d30381ec7e47aca147b59ba601aeaa26f1fdc19373 + size: 268 + sha256: 0e9b11f6414a0a179cd11dec55261a1f9995663fcf27bfd4a386c48652655404 original: - hackage: system-locale-0.3.0.0 + hackage: cryptoids-types-1.0.0@sha256:96a74b33a32ebeebf5bee08e2a205e5c1585b4b46b8bac086ca7fde49aec5f5b,1271 - completed: - hackage: hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814 + hackage: filepath-crypto-0.1.0.0@sha256:e02bc15858cf06edf9788a38b5b58d45e82c7f5589785a178a903d792af04125,1593 pantry-tree: - size: 442 - sha256: 347eac6c8a3c02fc0101444d6526b57b3c27785809149b12f90d8db57c721fea + size: 623 + sha256: bce236365ebdc6e5c46f740876a6fb5ad688e8ee3b305933822ab027e5b5fd86 original: - hackage: hlint-test-0.1.0.0 + hackage: filepath-crypto-0.1.0.0@sha256:e02bc15858cf06edf9788a38b5b58d45e82c7f5589785a178a903d792af04125,1593 - completed: - hackage: pkcs7-1.0.0.1@sha256:b26e5181868667abbde3ce17f9a61cf705eb695da073cdf82e1f9dfd6cc11176,3594 + hackage: hlibsass-0.1.10.1@sha256:08db56c633e9a83a642d8ea57dffa93112b092d05bf8f3b07491cfee9ee0dfa5,2565 pantry-tree: - size: 316 - sha256: ab3c2d2880179a945ab3122c51d1657ab4a7a628292b646e047cd32b0751a80c + size: 11229 + sha256: 39b62f1f3f30c5a9e12f9c6a040d6863edb5ce81951452e649152a18145ee1bc original: - hackage: pkcs7-1.0.0.1 + hackage: hlibsass-0.1.10.1@sha256:08db56c633e9a83a642d8ea57dffa93112b092d05bf8f3b07491cfee9ee0dfa5,2565 - completed: - hackage: systemd-2.2.0@sha256:a41399ad921e3c90bb04219a66821631c17c94326961f9b6c71542abb042375f,1477 + hackage: hsass-0.8.0@sha256:05fb3d435dbdf9f66a98db4e1ee57a313170a677e52ab3a5a05ced1fc42b0834,2899 pantry-tree: - size: 520 - sha256: 188d4e07a62653b24091dc25c0222deb7a95037630d17a13327d269391050b7d + size: 1448 + sha256: b25aeb947cb4e0b550f8a6f226d06503ef0edcb54712ad9cdd4fb2b05bf16c7c original: - hackage: systemd-2.2.0 + hackage: hsass-0.8.0@sha256:05fb3d435dbdf9f66a98db4e1ee57a313170a677e52ab3a5a05ced1fc42b0834,2899 - completed: - hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 + hackage: ip-1.7.2@sha256:2148bbc7b5e66ea7273b6014bb30483cc656b2cd4e53efaf165c2223bdbbeb46,3742 pantry-tree: - size: 3455 - sha256: 5ca7ce4bc22ab9d4427bb149b5e283ab9db43375df14f7131fdfd48775f36350 + size: 1437 + sha256: c60e78361b92eebfa341027377787e39de5a16218ab605456cf4cf1de5f58b2a original: - hackage: sandi-0.5 + hackage: ip-1.7.2@sha256:2148bbc7b5e66ea7273b6014bb30483cc656b2cd4e53efaf165c2223bdbbeb46,3742 - completed: - hackage: storable-endian-0.2.6@sha256:cae7aac2bfe6037660b2cf294891867e69bcd74e739a3b3ea759e9ad99d6c889,801 + hackage: natural-arithmetic-0.1.2.0@sha256:ac25a0561c8378530a62f02df83680afb193ed1059bb43e3130e0074b5b3f16b,3411 pantry-tree: - size: 223 - sha256: 6a8e43727f9b146238d4064fffc39d629f06622106922487fea922ec73aaee1e + size: 716 + sha256: e1e5b16f53fe2a7378d38dcae5069dcc1c6e37f8e1473f091ae1f7d788b1c688 original: - hackage: storable-endian-0.2.6 -- completed: - hackage: prometheus-metrics-ghc-1.0.1@sha256:d12cd520cbedff91bd193e0192056474723e953e69cdf817fb79494d110df390,1231 - pantry-tree: - size: 293 - sha256: b412f2835ee5791a7f4f634c416227b70bae50511666d9f68683e5e21b5c2821 - original: - hackage: prometheus-metrics-ghc-1.0.1 -- completed: - hackage: wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314 - pantry-tree: - size: 307 - sha256: 6d64803c639ed4c7204ea6fab0536b97d3ee16cdecb9b4a883cd8e56d3c61402 - original: - hackage: wai-middleware-prometheus-1.0.0 -- completed: - hackage: pandoc-2.9.2@sha256:fa04b214c79328a4519093a5e82fe961a21179539165b98773a6f8bfb66bc662,36181 - pantry-tree: - size: 88080 - sha256: 95eeae57b3d00eb7fa1accacab31e032f4d535c8c2cb992891a20d694eb00339 - original: - hackage: pandoc-2.9.2 -- completed: - hackage: doclayout-0.3@sha256:06c03875b1645e6ab835c40f9b73fd959b6c4232c01d06f07debedfae46723f2,2059 - pantry-tree: - size: 425 - sha256: ed2fc2dd826fbba67cb8018979be437b215735fab90dcc49ad30b296f7005eed - original: - hackage: doclayout-0.3 -- completed: - hackage: doctemplates-0.8.1@sha256:be34c3210d9ebbba1c10100e30d8c3ba3b6c34653ec2ed15f09e5d05055aa37d,3111 - pantry-tree: - size: 2303 - sha256: 9d4d8e7a85166ffd951b02f87be540607b55084c04730932346072329adf4913 - original: - hackage: doctemplates-0.8.1 -- completed: - hackage: binary-instances-1@sha256:b17565598b8df3241f9b46fa8e3a3368ecc8e3f2eb175d7c28f319042a6f5c79,2613 - pantry-tree: - size: 1035 - sha256: 938ffc6990cac12681c657f7afa93737eecf335e6f0212d8c0b7c1ea3e0f40f4 - original: - hackage: binary-instances-1 -- completed: - hackage: acid-state-0.16.0@sha256:a5640fd8d99bdb5f152476a2ae56cc8eb81864b280c8ec7d1387e81296ed844d,6190 - pantry-tree: - size: 13678 - sha256: c6e4b7f00d2a500e6286beafe3a2da7ba898a9ea31f5744df57cdce8a8f5890f - original: - hackage: acid-state-0.16.0 -- completed: - hackage: unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144 - pantry-tree: - size: 492 - sha256: 4959068a0caf410dd4b8046f0b0138e3cf6471abb0cc865c9993db3b2930d283 - original: - hackage: unidecode-0.1.0.4 -- completed: - hackage: token-bucket-0.1.0.1@sha256:d8e85f2fc373939975e7ace7907baee177531ab6e43df94e330a2357e64a2d11,1899 - pantry-tree: - size: 399 - sha256: b0b4a08ea1bf76bd108310f64d7f80e0f30b61ddc3d71f6cab7bdce329d2c1fa - original: - hackage: token-bucket-0.1.0.1 + hackage: natural-arithmetic-0.1.2.0@sha256:ac25a0561c8378530a62f02df83680afb193ed1059bb43e3130e0074b5b3f16b,3411 - completed: hackage: normaldistribution-1.1.0.3@sha256:2615b784c4112cbf6ffa0e2b55b76790290a9b9dff18a05d8c89aa374b213477,2160 pantry-tree: size: 269 sha256: 856818862d12df8b030fa9cfef2c4ffa604d06f0eb057498db245dfffcd60e3c original: - hackage: normaldistribution-1.1.0.3 + hackage: normaldistribution-1.1.0.3@sha256:2615b784c4112cbf6ffa0e2b55b76790290a9b9dff18a05d8c89aa374b213477,2160 - completed: - hackage: unordered-containers-0.2.11.0@sha256:ba70b8a9d7eebc2034bf92e5690b2dd71200e76aa9f3f93e0b6be3f27f244d18,4998 + hackage: pandoc-2.10.1@sha256:23d7ec480c7cb86740475a419d6ca4819987b6dd23bbae9b50bc3d42a7ed2f9f,36933 pantry-tree: - size: 1416 - sha256: d9b83f62373f509a441223f22f12e22e39b38ef3275dfca7c190a4795bebfed5 + size: 89646 + sha256: 08c8b20356152b9ee8161bacafda2dc1bed13d7db4cbf38ab040c1977b2d28d5 original: - hackage: unordered-containers-0.2.11.0 + hackage: pandoc-2.10.1@sha256:23d7ec480c7cb86740475a419d6ca4819987b6dd23bbae9b50bc3d42a7ed2f9f,36933 - completed: - hackage: base64-bytestring-1.1.0.0@sha256:190264fef9e65d9085f00ccda419137096d1dc94777c58272bc96821dc7f37c3,2334 + hackage: pkcs7-1.0.0.1@sha256:b26e5181868667abbde3ce17f9a61cf705eb695da073cdf82e1f9dfd6cc11176,3594 pantry-tree: - size: 850 - sha256: 9ade5b5911df97c37b249b84f123297049f19578cae171c647bf47683633427c + size: 316 + sha256: ab3c2d2880179a945ab3122c51d1657ab4a7a628292b646e047cd32b0751a80c original: - hackage: base64-bytestring-1.1.0.0 + hackage: pkcs7-1.0.0.1@sha256:b26e5181868667abbde3ce17f9a61cf705eb695da073cdf82e1f9dfd6cc11176,3594 +- completed: + hackage: primitive-offset-0.2.0.0@sha256:f8006927d5c0a3e83707610bbc5514aabe8f84a907ecb07edd2c815f58299dea,843 + pantry-tree: + size: 368 + sha256: 6dbc2fbfd70920a1de5a76d3715506edc0895c81a2f7b856d3abb027865d4605 + original: + hackage: primitive-offset-0.2.0.0@sha256:f8006927d5c0a3e83707610bbc5514aabe8f84a907ecb07edd2c815f58299dea,843 +- completed: + hackage: primitive-unlifted-0.1.3.0@sha256:a98f827740f5dcf097d885b3a47c32f4462204449620abc9d51b8c4f8619f9e6,1427 + pantry-tree: + size: 420 + sha256: c882dca2a96b98d02b0d21875b651edb11ac67d90e736c0de7a92c410a19eb7f + original: + hackage: primitive-unlifted-0.1.3.0@sha256:a98f827740f5dcf097d885b3a47c32f4462204449620abc9d51b8c4f8619f9e6,1427 +- completed: + hackage: prometheus-metrics-ghc-1.0.1.1@sha256:d378a7186a967140fe0e09d325fe5e3bfd7b77a1123934b40f81fdfed2eacbdc,1233 + pantry-tree: + size: 293 + sha256: 0732085a4148b269bbc15eeb7ab422e65ac287878a42a7388a7b6e140ec740e5 + original: + hackage: prometheus-metrics-ghc-1.0.1.1@sha256:d378a7186a967140fe0e09d325fe5e3bfd7b77a1123934b40f81fdfed2eacbdc,1233 +- completed: + hackage: run-st-0.1.1.0@sha256:a43245bb23984089016772481bf52bfe63eaff0c5040303f69c9b15e80872fdc,883 + pantry-tree: + size: 269 + sha256: 06d5d7ecf185a26c15e48cda6c30e8865dae715c528a31466701272fae36d822 + original: + hackage: run-st-0.1.1.0@sha256:a43245bb23984089016772481bf52bfe63eaff0c5040303f69c9b15e80872fdc,883 +- completed: + hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 + pantry-tree: + size: 3455 + sha256: 5ca7ce4bc22ab9d4427bb149b5e283ab9db43375df14f7131fdfd48775f36350 + original: + hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 +- completed: + hackage: system-locale-0.3.0.0@sha256:13b3982403d8ac8cc6138e68802be8d8e7cf7ebc4cbc7e47e99e3c0dd1be066a,1529 + pantry-tree: + size: 446 + sha256: 3b22af3e6315835bf614a0d30381ec7e47aca147b59ba601aeaa26f1fdc19373 + original: + hackage: system-locale-0.3.0.0@sha256:13b3982403d8ac8cc6138e68802be8d8e7cf7ebc4cbc7e47e99e3c0dd1be066a,1529 +- completed: + hackage: token-bucket-0.1.0.1@sha256:d8e85f2fc373939975e7ace7907baee177531ab6e43df94e330a2357e64a2d11,1899 + pantry-tree: + size: 399 + sha256: b0b4a08ea1bf76bd108310f64d7f80e0f30b61ddc3d71f6cab7bdce329d2c1fa + original: + hackage: token-bucket-0.1.0.1@sha256:d8e85f2fc373939975e7ace7907baee177531ab6e43df94e330a2357e64a2d11,1899 +- completed: + hackage: tuples-0.1.0.0@sha256:7006c1cab721ad3e39cdbf1ccb07ec050b94d654cc6e39277d46241eee6ac7c9,1088 + pantry-tree: + size: 320 + sha256: 57009cc671ed8e43738be3bf7b1392461ad086083df633a2f4f9c7206a14a79c + original: + hackage: tuples-0.1.0.0@sha256:7006c1cab721ad3e39cdbf1ccb07ec050b94d654cc6e39277d46241eee6ac7c9,1088 +- completed: + hackage: tz-0.1.3.4@sha256:bd311e202b8bdd15bcd6a4ca182e69794949d3b3b9f4aa835e9ccff011284979,5086 + pantry-tree: + size: 1179 + sha256: f6b8517eaaf3588afd1b3025fe6874a1ffff611001a803a26094c9cb40bc33f6 + original: + hackage: tz-0.1.3.4@sha256:bd311e202b8bdd15bcd6a4ca182e69794949d3b3b9f4aa835e9ccff011284979,5086 +- completed: + hackage: unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144 + pantry-tree: + size: 492 + sha256: 4959068a0caf410dd4b8046f0b0138e3cf6471abb0cc865c9993db3b2930d283 + original: + hackage: unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144 +- completed: + hackage: uuid-crypto-1.4.0.0@sha256:9e2f271e61467d9ea03e78cddad75a97075d8f5108c36a28d59c65abb3efd290,1325 + pantry-tree: + size: 364 + sha256: 6650b51ea060397c412b07b256c043546913292973284a7149ddd08f489b3e48 + original: + hackage: uuid-crypto-1.4.0.0@sha256:9e2f271e61467d9ea03e78cddad75a97075d8f5108c36a28d59c65abb3efd290,1325 +- completed: + hackage: wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314 + pantry-tree: + size: 307 + sha256: 6d64803c639ed4c7204ea6fab0536b97d3ee16cdecb9b4a883cd8e56d3c61402 + original: + hackage: wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314 snapshots: - completed: - size: 494635 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/12.yaml - sha256: a71c4293d8f461f455ff0d9815dfe4ab2f1adacd7e0bbc9a218f46ced8c4929a - original: lts-15.12 + size: 524392 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/8/8.yaml + sha256: 21b78cd42414558e6e381666a51ab92b405f969ab1d675137fd55ef557edc9a4 + original: nightly-2020-08-08 diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index bd02521e3..50a036d37 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -43,7 +43,7 @@ insertFile residual fileTitle = do fillDb :: DB () fillDb = do - AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings + AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod $ view appSettings now <- liftIO getCurrentTime let insert' :: (PersistRecordBackend r (YesodPersistBackend UniWorX), AtLeastOneUniqueKey r) => r -> YesodDB UniWorX (Key r) From 75124201311976ebcda0683f1e8756f4ef4533f3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 10 Aug 2020 16:31:38 +0200 Subject: [PATCH 2/8] chore: pull minio-hs from gitlab --- stack.yaml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/stack.yaml b/stack.yaml index 14ba29f32..ebd6b03a3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -34,9 +34,8 @@ extra-deps: commit: f8170266ab25b533576e96715bedffc5aa4f19fa subdirs: - colonnade - # - git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git - # commit: 9a4e3889a93cf71d6bbf45b673f6353b39f15d9f - - ../minio-hs + - git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git + commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1 # # - colonnade-1.2.0.2 From 0fcb65f9fac0d3bf54020d087294f473a0243b56 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 10 Aug 2020 21:59:16 +0200 Subject: [PATCH 3/8] refactor: hlint --- src/Application.hs | 14 +- src/Audit.hs | 2 +- src/Audit/Types.hs | 6 +- src/Auth/Dummy.hs | 4 +- src/Auth/LDAP.hs | 10 +- .../Monad/Trans/Memo/StateCache/Instances.hs | 2 +- src/Cron.hs | 6 +- src/Cron/Types.hs | 4 +- src/Crypto/Hash/Instances.hs | 2 +- src/CryptoID.hs | 4 +- src/Data/CaseInsensitive/Instances.hs | 2 +- src/Data/Fixed/Instances.hs | 2 +- src/Data/Maybe/Instances.hs | 2 +- src/Data/MonoTraversable/Instances.hs | 2 +- src/Data/Scientific/Instances.hs | 2 +- src/Data/Sum/Instances.hs | 2 +- src/Data/UUID/Instances.hs | 2 +- .../Instances/Reverse/MonoTraversable.hs | 6 +- src/Data/Universe/TH.hs | 4 +- src/Database/Esqueleto/Utils.hs | 8 +- src/Database/Esqueleto/Utils/TH.hs | 2 +- src/Database/Persist/TH/Directory.hs | 6 +- src/Foundation.hs | 163 +++++++++--------- src/Foundation/I18n.hs | 8 +- src/Foundation/Routes.hs | 4 +- src/Handler/Admin/StudyFeatures.hs | 20 +-- src/Handler/Admin/Test/Download.hs | 8 +- src/Handler/Admin/Tokens.hs | 6 +- src/Handler/Allocation/Accept.hs | 8 +- src/Handler/Allocation/Application.hs | 40 ++--- src/Handler/Allocation/Compute.hs | 2 +- src/Handler/Allocation/List.hs | 10 +- src/Handler/Allocation/Prios.hs | 8 +- src/Handler/Allocation/Register.hs | 4 +- src/Handler/Allocation/Show.hs | 2 +- src/Handler/Allocation/Users.hs | 10 +- src/Handler/Course/Application/Files.hs | 8 +- src/Handler/Course/Application/List.hs | 18 +- src/Handler/Course/Communication.hs | 2 +- src/Handler/Course/Edit.hs | 26 +-- src/Handler/Course/Events/Delete.hs | 16 +- src/Handler/Course/Events/Edit.hs | 2 +- src/Handler/Course/Events/Form.hs | 2 +- src/Handler/Course/Events/New.hs | 2 +- src/Handler/Course/News/Delete.hs | 12 +- src/Handler/Course/News/Download.hs | 2 +- src/Handler/Course/News/Edit.hs | 2 +- src/Handler/Course/News/Form.hs | 2 +- src/Handler/Course/ParticipantInvite.hs | 6 +- src/Handler/Course/Register.hs | 16 +- src/Handler/Course/Show.hs | 13 +- src/Handler/Course/User.hs | 8 +- src/Handler/Course/Users.hs | 68 ++++---- src/Handler/CryptoIDDispatch.hs | 4 +- src/Handler/Exam/AddUser.hs | 12 +- src/Handler/Exam/AutoOccurrence.hs | 12 +- src/Handler/Exam/Correct.hs | 18 +- src/Handler/Exam/CorrectorInvite.hs | 2 +- src/Handler/Exam/Form.hs | 14 +- src/Handler/Exam/List.hs | 4 +- src/Handler/Exam/New.hs | 6 +- src/Handler/Exam/Register.hs | 6 +- src/Handler/Exam/RegistrationInvite.hs | 8 +- src/Handler/Exam/Show.hs | 6 +- src/Handler/Exam/Users.hs | 32 ++-- src/Handler/ExamOffice/Course.hs | 4 +- src/Handler/ExamOffice/Exam.hs | 14 +- src/Handler/ExamOffice/Exams.hs | 24 ++- src/Handler/ExamOffice/ExternalExam.hs | 2 +- src/Handler/ExamOffice/Fields.hs | 4 +- src/Handler/ExamOffice/Users.hs | 8 +- src/Handler/ExternalExam/Edit.hs | 4 +- src/Handler/ExternalExam/Form.hs | 4 +- src/Handler/ExternalExam/List.hs | 4 +- src/Handler/ExternalExam/New.hs | 6 +- src/Handler/Help.hs | 10 +- src/Handler/Info.hs | 4 +- src/Handler/Material.hs | 6 +- src/Handler/Metrics.hs | 2 +- src/Handler/News.hs | 12 +- src/Handler/Participants.hs | 6 +- src/Handler/Profile.hs | 4 +- src/Handler/School.hs | 8 +- src/Handler/Sheet.hs | 2 +- src/Handler/Sheet/Current.hs | 2 +- src/Handler/Sheet/Download.hs | 2 +- src/Handler/Sheet/Edit.hs | 4 +- src/Handler/Sheet/Form.hs | 22 +-- src/Handler/Sheet/List.hs | 2 +- src/Handler/StorageKey.hs | 4 +- src/Handler/Submission.hs | 2 +- src/Handler/Submission/Assign.hs | 10 +- src/Handler/Submission/Correction.hs | 6 +- src/Handler/Submission/Helper.hs | 18 +- src/Handler/Submission/List.hs | 14 +- .../Submission/SubmissionUserInvite.hs | 2 +- src/Handler/Submission/Upload.hs | 2 +- src/Handler/SystemMessage.hs | 10 +- src/Handler/Term.hs | 6 +- src/Handler/Tutorial/Edit.hs | 2 +- src/Handler/Tutorial/Form.hs | 2 +- src/Handler/Tutorial/New.hs | 2 +- src/Handler/Users.hs | 26 +-- src/Handler/Users/Add.hs | 2 +- src/Handler/Utils.hs | 4 +- src/Handler/Utils/Allocation.hs | 28 +-- src/Handler/Utils/Communication.hs | 2 +- src/Handler/Utils/Course.hs | 4 +- src/Handler/Utils/Csv.hs | 8 +- src/Handler/Utils/DateTime.hs | 4 +- src/Handler/Utils/Delete.hs | 2 +- src/Handler/Utils/Exam.hs | 28 +-- src/Handler/Utils/ExamOffice/Exam.hs | 4 +- src/Handler/Utils/ExamOffice/ExternalExam.hs | 4 +- src/Handler/Utils/ExternalExam/Users.hs | 12 +- src/Handler/Utils/Files.hs | 6 +- src/Handler/Utils/Form.hs | 96 +++++------ src/Handler/Utils/Form/MassInput.hs | 18 +- src/Handler/Utils/Form/MassInput/TH.hs | 2 +- src/Handler/Utils/I18n.hs | 4 +- src/Handler/Utils/Invitations.hs | 8 +- src/Handler/Utils/Memcached.hs | 44 ++--- src/Handler/Utils/Pandoc.hs | 2 +- src/Handler/Utils/Rating.hs | 2 +- src/Handler/Utils/Rating/Format.hs | 12 +- src/Handler/Utils/Rating/Format/Legacy.hs | 2 +- src/Handler/Utils/SchoolLdap.hs | 4 +- src/Handler/Utils/StudyFeatures.hs | 4 +- src/Handler/Utils/Submission.hs | 84 ++++----- src/Handler/Utils/Table.hs | 2 +- src/Handler/Utils/Table/Columns.hs | 32 ++-- src/Handler/Utils/Table/Pagination.hs | 2 +- .../Table/Pagination/CsvColumnExplanations.hs | 2 +- src/Handler/Utils/Table/Pagination/Types.hs | 2 +- src/Handler/Utils/TermCandidates.hs | 2 +- src/Handler/Utils/Users.hs | 10 +- src/Handler/Utils/Widgets.hs | 6 +- src/Handler/Utils/Zip.hs | 6 +- src/Import/NoFoundation.hs | 2 +- src/Import/NoModel.hs | 3 + src/Jobs.hs | 2 +- src/Jobs/Crontab.hs | 28 +-- src/Jobs/Handler/Files.hs | 16 +- src/Jobs/Handler/HelpRequest.hs | 6 +- src/Jobs/Handler/QueueNotification.hs | 8 +- .../Handler/SendNotification/Allocation.hs | 10 +- .../SendNotification/CorrectionsAssigned.hs | 2 +- .../CorrectionsNotDistributed.hs | 2 +- .../SendNotification/CourseRegistered.hs | 4 +- .../Handler/SendNotification/ExamOffice.hs | 2 +- .../SendNotification/SubmissionEdited.hs | 10 +- .../SendNotification/SubmissionRated.hs | 2 +- src/Jobs/Handler/SendNotification/Utils.hs | 2 +- src/Jobs/Handler/SendPasswordReset.hs | 2 +- src/Jobs/Handler/SendTestEmail.hs | 2 +- src/Jobs/Handler/SynchroniseLdap.hs | 4 +- src/Jobs/HealthReport.hs | 8 +- src/Jobs/Queue.hs | 8 +- src/Jobs/Types.hs | 4 +- src/Ldap/Client/Pool.hs | 2 +- src/Mail.hs | 10 +- src/Model.hs | 4 +- src/Model/Migration.hs | 70 ++++---- src/Model/Migration/Types.hs | 4 +- src/Model/Migration/Version.hs | 2 +- src/Model/Tokens/Bearer.hs | 2 +- src/Model/Tokens/Lens.hs | 2 +- src/Model/Tokens/Session.hs | 6 +- src/Model/Types/Allocation.hs | 2 +- src/Model/Types/Common.hs | 2 +- src/Model/Types/Exam.hs | 10 +- src/Model/Types/Health.hs | 4 +- src/Model/Types/Languages.hs | 2 +- src/Model/Types/Misc.hs | 6 +- src/Model/Types/Security.hs | 2 +- src/Model/Types/Sheet.hs | 2 +- src/Model/Types/Submission.hs | 8 +- src/Model/Types/TH/JSON.hs | 2 +- src/Network/Mail/Mime/Instances.hs | 2 +- src/Network/Mime/TH.hs | 4 +- src/Settings/Cluster.hs | 4 +- src/Settings/Log.hs | 4 +- src/Settings/StaticFiles/Generator.hs | 2 +- src/Settings/StaticFiles/Webpack.hs | 6 +- src/Settings/WellKnownFiles.hs | 2 +- src/Settings/WellKnownFiles/TH.hs | 12 +- src/UnliftIO/Async/Utils.hs | 4 +- src/Utils.hs | 18 +- src/Utils/Allocation.hs | 16 +- src/Utils/Cookies/Registered.hs | 8 +- src/Utils/Csv.hs | 6 +- src/Utils/DB.hs | 4 +- src/Utils/DateTime.hs | 10 +- src/Utils/Failover.hs | 4 +- src/Utils/Files.hs | 8 +- src/Utils/Form.hs | 28 ++- src/Utils/Lens.hs | 10 +- src/Utils/Lens/TH.hs | 2 +- src/Utils/Metrics.hs | 8 +- src/Utils/Occurrences.hs | 2 +- src/Utils/Parameters.hs | 4 +- src/Utils/PathPiece.hs | 8 +- src/Utils/PersistentTokenBucket.hs | 8 +- src/Utils/Sql.hs | 6 +- src/Utils/Tokens.hs | 2 +- .../Backend/Persistent/Memcached.hs | 12 +- src/Web/ServerSession/Frontend/Yesod/Jwt.hs | 8 +- src/Yesod/Core/Instances.hs | 2 +- src/Yesod/Core/Types/Instances.hs | 2 +- src/Yesod/Form/Fields/Instances.hs | 2 +- stack.yaml | 1 + stack.yaml.lock | 21 +++ 212 files changed, 983 insertions(+), 962 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 12c92bdeb..490040eed 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -94,11 +94,11 @@ import Handler.Utils.Routes (classifyHandler) import qualified Data.Acid.Memory as Acid import qualified Web.ServerSession.Backend.Acid as Acid - + import qualified Ldap.Client as Ldap (Host(Plain, Tls)) import qualified Network.Minio as Minio - + import Web.ServerSession.Core (StorageException(..)) import GHC.RTS.Flags (getRTSFlags) @@ -142,7 +142,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX makeFoundation :: (MonadResource m, MonadUnliftIO m, MonadCatch m) => AppSettings -> m UniWorX makeFoundation appSettings'@AppSettings{..} = do registerGHCMetrics - + -- Some basic initializations: HTTP connection manager, logger, and static -- subsite. appHttpManager <- newManager @@ -356,7 +356,7 @@ makeApplication foundation = liftIO $ makeMiddleware foundation <*> toWaiAppPlai makeMiddleware :: MonadIO m => UniWorX -> m Middleware makeMiddleware app = do logWare <- makeLogWare - return $ observeHTTPRequestLatency classifyHandler . logWare . normalizeCookies . defaultMiddlewaresNoLogging + return $ observeHTTPRequestLatency classifyHandler . logWare . normalizeCookies . defaultMiddlewaresNoLogging where makeLogWare = do logWareMap <- liftIO $ newTVarIO HashMap.empty @@ -391,7 +391,7 @@ makeMiddleware app = do respond $ Wai.mapResponseHeaders (const resHdrs') res where parseSetCookie' :: ByteString -> IO (Maybe SetCookie) parseSetCookie' = fmap (either (\(_ :: SomeException) -> Nothing) Just) . try . evaluate . force . parseSetCookie - + go [] = return [] go (hdr@(hdrName, hdrValue) : hdrs) | hdrName == hSetCookie = do @@ -458,7 +458,7 @@ warpSettings foundation = defaultSettings Just (SessionDoesNotExist{} :: StorageException (AcidStorage SessionMap)) -> False _other -> True ] - + getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv @@ -479,7 +479,7 @@ develMain = runResourceT $ do lift $ threadDelay 100e3 whenM (lift $ doesFileExist "yesod-devel/devel-terminate") $ callCC ($ ()) - + void . liftIO $ installHandler sigINT (Signals.Catch $ return ()) Nothing runAppLoggingT foundation $ handleJobs foundation void . liftIO $ awaitTermination `race` runSettings wsettings app diff --git a/src/Audit.hs b/src/Audit.hs index fb52cb96d..6027f80ea 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -54,7 +54,7 @@ getRemote = handle testHandler $ do guard $ h `elem` ["x-real-ip", "x-forwarded-for"] v' <- either (const mzero) return $ Text.decodeUtf8' v maybeToList $ IP.decode v' - + byRemoteHost wai = case Wai.remoteHost wai of Wai.SockAddrInet _ hAddr -> let (b1, b2, b3, b4) = Wai.hostAddressToTuple hAddr diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 573a91af5..7b5757e94 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -23,7 +23,7 @@ data Transaction { transactionExam :: ExamId , transactionUser :: UserId } - + | TransactionExamPartResultEdit { transactionExamPart :: ExamPartId , transactionUser :: UserId @@ -88,7 +88,7 @@ data Transaction { transactionSubmission :: SubmissionId , transactionUser :: UserId } - + | TransactionSubmissionFileEdit { transactionSubmissionFile :: SubmissionFileId , transactionSubmission :: SubmissionId @@ -133,7 +133,7 @@ data Transaction { transactionExternalExam :: ExternalExamId , transactionSchool :: SchoolId } - + | TransactionExternalExamStaffEdit { transactionExternalExam :: ExternalExamId , transactionUser :: UserId diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs index a1cd8ad3b..859b04554 100644 --- a/src/Auth/Dummy.hs +++ b/src/Auth/Dummy.hs @@ -45,7 +45,7 @@ dummyLogin = AuthPlugin{..} where apName :: Text apName = "dummy" - + apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent apDispatch method [] | encodeUtf8 method == methodPost = liftSubHandler $ do ((loginRes, _), _) <- runFormPost $ renderWForm FormStandard dummyForm @@ -62,7 +62,7 @@ dummyLogin = AuthPlugin{..} setCredsRedirect $ Creds apName (CI.original ident) [] apDispatch _ [] = badMethod apDispatch _ _ = notFound - + apLogin :: (Route Auth -> Route site) -> WidgetFor site () apLogin toMaster = do (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormStandard dummyForm diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index dac6bd1fd..9b57c8904 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -52,7 +52,7 @@ findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM [ ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident , ldapUserMatriculation Ldap.:= Text.encodeUtf8 ident ] - + findUserMatr :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry] findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters where @@ -76,8 +76,8 @@ ldapUserFirstName = Ldap.Attr "givenName" ldapUserSurname = Ldap.Attr "sn" ldapUserTitle = Ldap.Attr "title" ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy" -ldapUserFieldName = Ldap.Attr "LMU-Stg-Fach" -ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString" +ldapUserFieldName = Ldap.Attr "LMU-Stg-Fach" +ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString" ldapSex = Ldap.Attr "schacGender" ldapUserSubTermsSemester = Ldap.Attr "LMU-Stg-FachundFS" @@ -145,7 +145,7 @@ campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return [] -> throwM CampusUserNoResult [Ldap.SearchEntry _ attrs] -> return attrs _otherwise -> throwM CampusUserAmbiguous - + campusUserMatr' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList [])) campusUserMatr' pool mode = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr pool mode @@ -177,7 +177,7 @@ campusLogin pool mode = AuthPlugin{..} where apName :: Text apName = apLdap - + apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent apDispatch method [] | encodeUtf8 method == methodPost = liftSubHandler $ do ((loginRes, _), _) <- runFormPost $ renderWForm FormStandard campusForm diff --git a/src/Control/Monad/Trans/Memo/StateCache/Instances.hs b/src/Control/Monad/Trans/Memo/StateCache/Instances.hs index e885eb655..5e5d6d977 100644 --- a/src/Control/Monad/Trans/Memo/StateCache/Instances.hs +++ b/src/Control/Monad/Trans/Memo/StateCache/Instances.hs @@ -16,7 +16,7 @@ instance MonadResource m => MonadResource (StateCache c m) where instance MonadLogger m => MonadLogger (StateCache c m) instance MonadLoggerIO m => MonadLoggerIO (StateCache c m) - + instance MonadHandler m => MonadHandler (StateCache c m) where type HandlerSite (StateCache c m) = HandlerSite m type SubHandlerSite (StateCache c m) = SubHandlerSite m diff --git a/src/Cron.hs b/src/Cron.hs index b448bf335..4697c4bf8 100644 --- a/src/Cron.hs +++ b/src/Cron.hs @@ -21,7 +21,7 @@ import qualified Data.Set as Set import Utils.Lens hiding (from, to) - + data CronDate = CronDate { cdYear, cdWeekYear, cdWeekOfYear, cdDayOfYear , cdMonth, cdWeekOfMonth, cdDayOfMonth @@ -101,7 +101,7 @@ instance Alternative CronNextMatch where _ <|> MatchAsap = MatchAsap MatchAsap <|> _ = MatchAsap (MatchAt a) <|> (MatchAt _) = MatchAt a - + listToMatch :: [a] -> CronNextMatch a listToMatch [] = MatchNone @@ -203,7 +203,7 @@ nextCronMatch tz mPrev prec now c@Cron{..} = onlyOnceWithinPrec $ case notAfter in case execRef now False cronInitial of MatchAsap | now < cutoffTime -> MatchAt cutoffTime - MatchAt ts + MatchAt ts | ts < cutoffTime -> MatchAt cutoffTime other -> other CronRepeatScheduled cronNext diff --git a/src/Cron/Types.hs b/src/Cron/Types.hs index 00eec5047..648f44449 100644 --- a/src/Cron/Types.hs +++ b/src/Cron/Types.hs @@ -11,12 +11,12 @@ import ClassyPrelude import Utils.Lens.TH -import Data.Time +import Data.Time import Numeric.Natural import qualified Data.Set as Set - + data CronMatch = CronMatchAny diff --git a/src/Crypto/Hash/Instances.hs b/src/Crypto/Hash/Instances.hs index 27304d542..93bf63516 100644 --- a/src/Crypto/Hash/Instances.hs +++ b/src/Crypto/Hash/Instances.hs @@ -26,7 +26,7 @@ instance HashAlgorithm hash => PersistField (Digest hash) where fromPersistValue _ = Left "Digest values must be converted from PersistByteString or PersistText" instance HashAlgorithm hash => PersistFieldSql (Digest hash) where - sqlType _ = SqlBlob + sqlType _ = SqlBlob instance HashAlgorithm hash => PathPiece (Digest hash) where toPathPiece = showToPathPiece diff --git a/src/CryptoID.hs b/src/CryptoID.hs index a6cfb4d62..cc2f9a2ff 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -38,7 +38,7 @@ encrypt :: forall plaintext ciphertext m. , Typeable ciphertext , PathPiece plaintext ) - => plaintext -> m (I.CryptoID ciphertext plaintext) + => plaintext -> m (I.CryptoID ciphertext plaintext) encrypt plain = $cachedHereBinary (toPathPiece plain) $ I.encrypt plain decrypt :: forall plaintext ciphertext m. @@ -47,7 +47,7 @@ decrypt :: forall plaintext ciphertext m. , Typeable plaintext , PathPiece ciphertext ) - => I.CryptoID ciphertext plaintext -> m plaintext + => I.CryptoID ciphertext plaintext -> m plaintext decrypt cipher = $cachedHereBinary (toPathPiece $ ciphertext cipher) $ I.decrypt cipher diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index 2b374fe63..512195097 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -38,7 +38,7 @@ instance PersistField (CI String) where toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 . pack $ CI.original ciText fromPersistValue (PersistDbSpecific bs) = Right . CI.mk . unpack $ Text.decodeUtf8 bs fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x - + instance PersistFieldSql (CI Text) where sqlType _ = SqlOther "citext" diff --git a/src/Data/Fixed/Instances.hs b/src/Data/Fixed/Instances.hs index 7593400e3..fafcba383 100644 --- a/src/Data/Fixed/Instances.hs +++ b/src/Data/Fixed/Instances.hs @@ -16,7 +16,7 @@ import Data.Proxy (Proxy(..)) import Data.Scientific import Data.Scientific.Instances () - + instance HasResolution a => ToMarkup (Fixed a) where toMarkup = toMarkup . showFixed True diff --git a/src/Data/Maybe/Instances.hs b/src/Data/Maybe/Instances.hs index 4b6eaf9e8..28c0e3557 100644 --- a/src/Data/Maybe/Instances.hs +++ b/src/Data/Maybe/Instances.hs @@ -10,4 +10,4 @@ import Text.Blaze (ToMarkup(..), string) instance ToMarkup a => ToMarkup (Maybe a) where toMarkup Nothing = string "" - toMarkup (Just x) = toMarkup x \ No newline at end of file + toMarkup (Just x) = toMarkup x diff --git a/src/Data/MonoTraversable/Instances.hs b/src/Data/MonoTraversable/Instances.hs index 13405c291..dcf89bd63 100644 --- a/src/Data/MonoTraversable/Instances.hs +++ b/src/Data/MonoTraversable/Instances.hs @@ -19,7 +19,7 @@ instance MonoFunctor All where instance MonoPointed Any where opoint = Any - + instance MonoPointed All where opoint = All diff --git a/src/Data/Scientific/Instances.hs b/src/Data/Scientific/Instances.hs index 85c46f844..cee91482d 100644 --- a/src/Data/Scientific/Instances.hs +++ b/src/Data/Scientific/Instances.hs @@ -11,5 +11,5 @@ import Web.PathPieces instance PathPiece Scientific where - toPathPiece = pack . formatScientific Fixed Nothing + toPathPiece = pack . formatScientific Fixed Nothing fromPathPiece = readFromPathPiece diff --git a/src/Data/Sum/Instances.hs b/src/Data/Sum/Instances.hs index 81c99f393..2b92dfcad 100644 --- a/src/Data/Sum/Instances.hs +++ b/src/Data/Sum/Instances.hs @@ -10,4 +10,4 @@ import Data.Monoid (Sum(..)) import Text.Blaze (ToMarkup(..)) instance ToMarkup a => ToMarkup (Sum a) where - toMarkup = toMarkup . getSum \ No newline at end of file + toMarkup = toMarkup . getSum diff --git a/src/Data/UUID/Instances.hs b/src/Data/UUID/Instances.hs index 38b20d104..c75d33ee9 100644 --- a/src/Data/UUID/Instances.hs +++ b/src/Data/UUID/Instances.hs @@ -10,7 +10,7 @@ import qualified Data.UUID as UUID import Database.Persist.Sql import Text.Blaze (ToMarkup(..)) - + instance PathPiece UUID where fromPathPiece = UUID.fromString . unpack diff --git a/src/Data/Universe/Instances/Reverse/MonoTraversable.hs b/src/Data/Universe/Instances/Reverse/MonoTraversable.hs index aaa50ca73..a9153690b 100644 --- a/src/Data/Universe/Instances/Reverse/MonoTraversable.hs +++ b/src/Data/Universe/Instances/Reverse/MonoTraversable.hs @@ -7,11 +7,11 @@ module Data.Universe.Instances.Reverse.MonoTraversable import Data.Universe import Data.MonoTraversable -import Data.Universe.Instances.Reverse - +import Data.Universe.Instances.Reverse + type instance Element (a -> b) = b instance Finite a => MonoFoldable (a -> b) instance (Ord a, Finite a) => MonoTraversable (a -> b) - + diff --git a/src/Data/Universe/TH.hs b/src/Data/Universe/TH.hs index 192182320..03250be58 100644 --- a/src/Data/Universe/TH.hs +++ b/src/Data/Universe/TH.hs @@ -23,7 +23,7 @@ import Data.List (elemIndex) getTVBName :: TyVarBndr -> Name getTVBName (PlainTV name ) = name getTVBName (KindedTV name _) = name - + finiteEnum :: Name -> DecsQ @@ -33,7 +33,7 @@ finiteEnum tName = do let datatype = foldl appT (conT datatypeName) $ map (varT . getTVBName) datatypeVars tUniverse = [e|universeF :: [$(datatype)]|] - + [d| instance Bounded $(datatype) where minBound = head $(tUniverse) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 474fe9fe9..43f48be7b 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -189,7 +189,7 @@ orderByList :: PersistField a => [a] -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Va orderByList vals = let sortUni = zip [1..] vals -- memoize this, might not work due to polymorphism in \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val . succ $ List.length vals) - + orderByOrd :: (Ord a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int) orderByOrd = orderByList $ List.sort universeF @@ -199,12 +199,12 @@ orderByEnum = orderByList $ List.sortOn fromEnum universeF lower :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) lower = E.unsafeSqlFunction "LOWER" - + strip :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) strip = E.unsafeSqlFunction "TRIM" infix 4 `ciEq` - + ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) ciEq a b = lower a E.==. lower b @@ -242,7 +242,7 @@ maybe onNothing onJust val = E.case_ (onJust $ E.veryUnsafeCoerceSqlExprValue val) ] (E.else_ onNothing) - + infix 4 `maybeEq` maybeEq :: PersistField a diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs index b0c6a3699..988915aa0 100644 --- a/src/Database/Esqueleto/Utils/TH.hs +++ b/src/Database/Esqueleto/Utils/TH.hs @@ -46,7 +46,7 @@ sqlInTuple arity = do xsV <- newName "xs" let - matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) `sqlEq` $(xE)|]) $ zip vVs xVs) + matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) $ zipWith (\(varE -> vE) (varE -> xE) -> [e|E.val $(vE) `sqlEq` $(xE)|]) vVs xVs) tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars instanceD (cxt $ map (\v -> [t|SqlEq $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|] diff --git a/src/Database/Persist/TH/Directory.hs b/src/Database/Persist/TH/Directory.hs index 66966913c..f0395102b 100644 --- a/src/Database/Persist/TH/Directory.hs +++ b/src/Database/Persist/TH/Directory.hs @@ -18,13 +18,13 @@ import qualified System.Directory.Tree as DirTree import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT) import Control.Lens - + persistDirectoryWith :: PersistSettings -> FilePath -> Q Exp persistDirectoryWith settings dir = do files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> runMaybeT $ do fn <- MaybeT . return . fromNullable $ takeFileName fp - guard . not $ head fn == '.' + guard $ head fn /= '.' guard . not $ head fn == '#' && last fn == '#' lift $ do @@ -32,5 +32,5 @@ persistDirectoryWith settings dir = do SIO.hSetEncoding h SIO.utf8_bom Text.hGetContents h mapM_ qAddDependentFile . toListOf (traverse . filtered (has $ _2 . _Just) . _1) $ DirTree.zipPaths files - + parseReferences settings . Text.intercalate "\n" . toListOf (traverse . _Just) $ DirTree.dirTree files diff --git a/src/Foundation.hs b/src/Foundation.hs index c2809cab3..1388997c0 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -15,7 +15,8 @@ import Foundation.Routes as Foundation import Import.NoFoundation hiding (embedFile) -import Database.Persist.Sql (runSqlPool) +import Database.Persist.Sql + ( runSqlPool, transactionUndo, SqlReadBackend(..) ) import Text.Hamlet (hamletFile) import Yesod.Auth.Message @@ -105,7 +106,6 @@ import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession import Web.Cookie import Yesod.Core.Types (GHState(..), HandlerData(..), HandlerContents, RunHandlerEnv(rheSite, rheChild)) -import Database.Persist.Sql (transactionUndo, SqlReadBackend(..)) import qualified Control.Retry as Retry import GHC.IO.Exception (IOErrorType(OtherError)) @@ -196,7 +196,7 @@ data Nav makeLenses_ ''Nav makePrisms ''Nav - + data NavChildren type instance Children NavChildren a = ChildrenNavChildren a type family ChildrenNavChildren a where @@ -217,13 +217,13 @@ navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M` where shortCircuit :: HandlerContents -> m Bool shortCircuit _ = return False - + accessCheck :: HasRoute UniWorX route => NavType -> route -> m Bool accessCheck nt (urlRoute -> route) = do authCtx <- getAuthContext $memcachedByHere (Just $ Right 120) (authCtx, nt, route) $ bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route - + getTimeLocale' :: [Lang] -> TimeLocale getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")]) @@ -244,7 +244,7 @@ appLanguagesOpts = do } langOptions = map mkOption $ toList appLanguages return $ mkOptionList langOptions - + instance RenderMessage UniWorX WeekDay where renderMessage _ ls wDay = pack . fst $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7) @@ -419,7 +419,7 @@ requireCurrentBearerRestrictions = runMaybeT $ do bearer <- requireBearerToken route <- MaybeT getCurrentRoute hoistMaybe $ bearer ^? _bearerRestrictionIx route - + maybeCurrentBearerRestrictions :: forall a m. ( MonadHandler m , HandlerSite m ~ UniWorX @@ -450,7 +450,7 @@ isDryRun = $cachedHere $ orM mAuthId <- maybeAuthId currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute isWrite <- isWriteRequest currentRoute - + let noTokenAuth :: AuthDNF -> AuthDNF noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar @@ -528,7 +528,7 @@ tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn - + E.where_ $ examOfficeExternalExamResultAuth (E.val authId) eexamResult guardMExceptT hasUsers $ unauthorizedI MsgUnauthorizedExternalExamExamOffice return Authorized @@ -635,7 +635,7 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID Submission{..} <- MaybeT . lift $ get sid - guard $ maybe False (== authId) submissionRatingBy + guard $ Just authId == submissionRatingBy return Authorized CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh @@ -715,7 +715,7 @@ tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route o E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val course E.&&. submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid - + return Authorized r -> $unsupportedAuthPredicate AuthSubmissionGroup r tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of @@ -742,7 +742,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of -> guard $ visible && NTop (Just cTime) <= NTop examDeregisterUntil ERegisterOccR occn -> do - occId <- (>>= hoistMaybe) . $cachedHereBinary (eId, occn) . lift . getKeyBy $ UniqueExamOccurrence eId occn + occId <- hoistMaybe <=< $cachedHereBinary (eId, occn) . lift . getKeyBy $ UniqueExamOccurrence eId occn if | (registration >>= examRegistrationOccurrence . entityVal) == Just occId -> guard $ visible @@ -850,7 +850,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of guard $ NTop (Just now) <= NTop deregUntil return Authorized _other -> unauthorizedI MsgUnauthorizedCourseTime - + CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do Entity course Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course @@ -879,7 +879,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId - cTime <- (NTop . Just) <$> liftIO getCurrentTime + cTime <- NTop . Just <$> liftIO getCurrentTime guard $ NTop systemMessageFrom <= cTime && NTop systemMessageTo >= cTime return Authorized @@ -887,7 +887,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId - cTime <- (NTop . Just) <$> liftIO getCurrentTime + cTime <- NTop . Just <$> liftIO getCurrentTime guard $ NTop systemMessageFrom <= cTime && NTop systemMessageTo >= cTime return Authorized @@ -895,7 +895,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of CNewsR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsTime) $ do nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID CourseNews{courseNewsVisibleFrom} <- $cachedHereBinary nId . MaybeT $ get nId - cTime <- (NTop . Just) <$> liftIO getCurrentTime + cTime <- NTop . Just <$> liftIO getCurrentTime guard $ NTop courseNewsVisibleFrom <= cTime return Authorized @@ -1195,7 +1195,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of when onlyActive $ E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive -- participant has at least one submission - when (not onlyActive) $ + unless onlyActive $ mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet @@ -1205,7 +1205,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is member of a submissionGroup - when (not onlyActive) $ + unless onlyActive $ mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse @@ -1222,7 +1222,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is a tutorial user - when (not onlyActive) $ + unless onlyActive $ mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse @@ -1254,7 +1254,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant has an exam result for this course - when (not onlyActive) $ + unless onlyActive $ mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse @@ -1263,7 +1263,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh -- participant is registered for an exam for this course - when (not onlyActive) $ + unless onlyActive $ mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse @@ -1271,21 +1271,19 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh - - return () tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of CourseR tid ssh csh (CUserR cID) -> maybeT (unauthorizedI MsgUnauthorizedApplicant) $ do - uid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID + uid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID isApplicant <- isCourseApplicant tid ssh csh uid guard isApplicant return Authorized - + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedApplicantSelf) $ do uid <- hoistMaybe mAuthId isApplicant <- isCourseApplicant tid ssh csh uid guard isApplicant return Authorized - + r -> $unsupportedAuthPredicate AuthApplicant r where isCourseApplicant tid ssh csh uid = lift . $cachedHereBinary (uid, tid, ssh, csh) . E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do @@ -1628,10 +1626,10 @@ instance Yesod UniWorX where makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of SessionStorageMemcachedSql sqlStore - -> mkBackend =<< stateSettings <$> ServerSession.createState sqlStore + -> mkBackend . stateSettings =<< ServerSession.createState sqlStore SessionStorageAcid acidStore | appServerSessionAcidFallback - -> mkBackend =<< stateSettings <$> ServerSession.createState acidStore + -> mkBackend . stateSettings =<< ServerSession.createState acidStore _other -> return Nothing where @@ -1664,7 +1662,7 @@ instance Yesod UniWorX where notForBearer' (SessionBackend load) = let load' req | aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req - , any (is _Just) $ map W.extractBearerAuth aHdrs + , any (is _Just . W.extractBearerAuth) aHdrs = return (mempty, const $ return []) | otherwise = load req @@ -1686,7 +1684,7 @@ instance Yesod UniWorX where dryRun <- isDryRun if | dryRun -> do hData <- ask - prevState <- readIORef (handlerState hData) + prevState <- readIORef (handlerState hData) let restoreSession = modifyIORef (handlerState hData) $ @@ -1698,7 +1696,7 @@ instance Yesod UniWorX where handler' = local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheSite = site', rheChild = site' } }) handler addCustomHeader HeaderDryRun ("1" :: Text) - + handler' `finally` restoreSession | otherwise -> handler updateFavouritesMiddleware :: Handler a -> Handler a @@ -1893,7 +1891,7 @@ updateFavourites :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) updateFavourites cData = void . runMaybeT $ do $logDebugS "updateFavourites" "Updating favourites" - now <- liftIO $ getCurrentTime + now <- liftIO getCurrentTime uid <- MaybeT $ liftHandler maybeAuthId mcid <- for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh User{userMaxFavourites} <- MaybeT $ get uid @@ -2004,7 +2002,7 @@ siteLayout' headingOverride widget = do [ E.when_ isCurrent E.then_ . E.just $ E.val FavouriteCurrent , E.when_ isAssociated E.then_ . E.just $ E.val FavouriteParticipant ] (E.else_ $ courseFavourite E.?. CourseFavouriteReason) - + E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent return (course, reason) @@ -2016,7 +2014,7 @@ siteLayout' headingOverride widget = do let favouriteTerms :: [TermIdentifier] favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _) -> Set.singleton $ unTermKey courseTerm) favourites' - + favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite) -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR favouriteReason = fromMaybe FavouriteCurrent mFavourite @@ -2028,7 +2026,7 @@ siteLayout' headingOverride widget = do $logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..." items <- memcachedLimitedKeyTimeoutBy MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1 - (Right <$> appFavouritesQuickActionsCacheTTL) + (Right <$> appFavouritesQuickActionsCacheTTL) appFavouritesQuickActionsTimeout cK cK @@ -2241,7 +2239,7 @@ getSystemMessageState smId = liftHandler $ do applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m () applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do lift $ maybeAuthId >>= traverse_ syncSystemMessageHidden - + cRoute <- lift getCurrentRoute guard $ cRoute /= Just NewsR @@ -2258,14 +2256,14 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) , systemMessageHiddenTime } [ SystemMessageHiddenTime =. systemMessageHiddenTime ] - + when (maybe False (maybe (const True) (<=) userSystemMessageHidden) userSystemMessageUnhidden) $ do deleteBy $ UniqueSystemMessageHidden uid smId modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm) -> fmap MergeHashMap . assertM' (/= mempty) $ HashMap.update (\smSt' -> assertM' (/= mempty) $ smSt' { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = Nothing }) cID hm - + applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do guard $ not systemMessageNewsOnly @@ -2325,7 +2323,7 @@ instance YesodBreadcrumbs UniWorX where User{..} <- MaybeT . runDB $ get uid return (userDisplayName, Just UsersR) breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID - breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID + breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID breadcrumb (UserNotificationR cID) = do mayList <- hasReadAccessTo UsersR if @@ -2344,12 +2342,12 @@ instance YesodBreadcrumbs UniWorX where breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing breadcrumb AdminR = i18nCrumb MsgAdminHeading Nothing - breadcrumb AdminFeaturesR = i18nCrumb MsgAdminFeaturesHeading $ Just AdminR + breadcrumb AdminFeaturesR = i18nCrumb MsgAdminFeaturesHeading $ Just AdminR breadcrumb AdminTestR = i18nCrumb MsgMenuAdminTest $ Just AdminR breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR - + breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR breadcrumb (SchoolR ssh SchoolEditR) = maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do School{..} <- MaybeT . runDB $ get ssh @@ -2403,12 +2401,12 @@ instance YesodBreadcrumbs UniWorX where AShowR -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do mr <- getMessageRender Entity _ Allocation{allocationName} <- MaybeT . runDB . getBy $ TermSchoolAllocationShort tid ssh ash - return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just $ AllocationListR) + return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just AllocationListR) ARegisterR -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do cid <- decrypt cID Course{..} <- hoist runDB $ do - aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash + aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash guardM . lift $ exists [ AllocationCourseAllocation ==. aid, AllocationCourseCourse ==. cid ] MaybeT $ get cid return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR) @@ -2460,7 +2458,7 @@ instance YesodBreadcrumbs UniWorX where CNDeleteR -> i18nCrumb MsgBreadcrumbCourseNewsDelete . Just $ CNewsR tid ssh csh cID CNShowR CNArchiveR -> i18nCrumb MsgBreadcrumbCourseNewsArchive . Just $ CNewsR tid ssh csh cID CNShowR CNFileR _ -> i18nCrumb MsgBreadcrumbCourseNewsFile . Just $ CNewsR tid ssh csh cID CNShowR - + breadcrumb (CourseR tid ssh csh CEventsNewR) = i18nCrumb MsgMenuCourseEventNew . Just $ CourseR tid ssh csh CShowR breadcrumb (CourseR tid ssh csh (CourseEventR _cID sRoute)) = case sRoute of CEvEditR -> i18nCrumb MsgMenuCourseEventEdit . Just $ CourseR tid ssh csh CShowR @@ -2554,7 +2552,7 @@ instance YesodBreadcrumbs UniWorX where breadcrumb CorrectionsDownloadR = i18nCrumb MsgMenuCorrectionsDownload $ Just CorrectionsR breadcrumb (CryptoUUIDDispatchR _) = i18nCrumb MsgBreadcrumbCryptoIDDispatch Nothing - + breadcrumb (MessageR _) = do mayList <- (== Authorized) <$> evalAccess MessageListR False if @@ -2581,9 +2579,9 @@ instance YesodBreadcrumbs UniWorX where | otherwise -> EExamListR EEEditR -> i18nCrumb MsgBreadcrumbExternalExamEdit . Just $ EExamR tid ssh coursen examn EEShowR EEUsersR -> i18nCrumb MsgBreadcrumbExternalExamUsers . Just $ EExamR tid ssh coursen examn EEShowR - EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR - EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR - + EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR + EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR + -- breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId] @@ -2666,7 +2664,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the } , do mCurrentRoute <- getCurrentRoute - + return NavHeader { navHeaderRole = NavHeaderSecondary , navIcon = IconMenuHelp @@ -2678,7 +2676,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navQuick' = mempty , navForceActive = False } - } + } , return $ NavFooter NavLink { navLabel = MsgMenuDataProt , navRoute = LegalR :#: ("data-protection" :: Text) @@ -2787,7 +2785,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the { navHeaderRole = NavHeaderPrimary , navLabel = SomeMessage MsgAdminHeading , navIcon = IconMenuAdmin - , navChildren = + , navChildren = [ NavLink { navLabel = MsgMenuUsers , navRoute = UsersR @@ -2858,7 +2856,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the { navHeaderRole = NavHeaderPrimary , navLabel = SomeMessage (mempty :: Text) , navIcon = IconMenuExtra - , navChildren = + , navChildren = [ NavLink { navLabel = MsgMenuCourseNew , navRoute = CourseNewR @@ -3084,7 +3082,7 @@ pageActions (CourseR tid ssh csh CShowR) = do , navAccess' = do uid <- requireAuthId runDB $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh E.selectExists $ do (_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid) E.where_ $ E.not_ isForced @@ -3362,7 +3360,7 @@ pageActions HelpR = return , ("allocations", MsgInfoLecturerAllocations) ] :: [(Text, UniWorXMessage)] return NavLink - { navLabel + { navLabel , navRoute = InfoLecturerR :#: section , navAccess' = return True , navType = NavTypeLink { navModal = False } @@ -3477,7 +3475,7 @@ pageActions (AllocationR tid ssh ash AShowR) = return } , navChildren = [] } - ] + ] pageActions (AllocationR tid ssh ash AUsersR) = return [ NavPageActionPrimary { navLink = NavLink @@ -3501,7 +3499,7 @@ pageActions (AllocationR tid ssh ash AUsersR) = return } , navChildren = [] } - ] + ] pageActions CourseListR = do participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR return @@ -3538,7 +3536,7 @@ pageActions CourseListR = do } , navChildren = participantsSecondary } - ] + ] pageActions CourseNewR = return [ NavPageActionPrimary { navLink = NavLink @@ -3578,14 +3576,13 @@ pageActions (CourseR tid ssh csh CCorrectionsR) = return case muid of Nothing -> return False (Just uid) -> do - ok <- runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do + runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh - return ok , navType = NavTypeLink { navModal = False } , navQuick' = navQuick NavQuickViewPageActionSecondary , navForceActive = False @@ -3609,7 +3606,7 @@ pageActions (CourseR tid ssh csh SheetListR) = do , navChildren = correctionsSecondary } showCorrections <- maybeT (return False) $ True <$ navAccess navCorrections - + return $ [ NavPageActionPrimary { navLink = NavLink @@ -3956,7 +3953,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = do , navChildren = subsSecondary } showSubmissions <- maybeT (return False) $ True <$ navAccess navSubmissions - + return $ [ NavPageActionPrimary { navLink = NavLink @@ -4373,19 +4370,19 @@ pageHeading UsersR = Just $ i18nHeading MsgUsers pageHeading (AdminUserR _) = Just $ i18nHeading MsgAdminUserHeading -pageHeading (AdminTestR) - = Just $ [whamlet|Internal Code Demonstration Page|] -pageHeading (AdminErrMsgR) +pageHeading AdminTestR + = Just [whamlet|Internal Code Demonstration Page|] +pageHeading AdminErrMsgR = Just $ i18nHeading MsgErrMsgHeading -pageHeading (InfoR) +pageHeading InfoR = Just $ i18nHeading MsgInfoHeading -pageHeading (LegalR) +pageHeading LegalR = Just $ i18nHeading MsgLegalHeading -pageHeading (VersionR) +pageHeading VersionR = Just $ i18nHeading MsgVersionHeading -pageHeading (HelpR) +pageHeading HelpR = Just $ i18nHeading MsgHelpRequest pageHeading ProfileR @@ -4408,8 +4405,8 @@ pageHeading (TermSchoolCourseListR tid ssh) School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh i18nHeading $ MsgTermSchoolCourseListHeading tid school -pageHeading (CourseListR) - = Just $ i18nHeading $ MsgCourseListTitle +pageHeading CourseListR + = Just $ i18nHeading MsgCourseListTitle pageHeading CourseNewR = Just $ i18nHeading MsgCourseNewHeading pageHeading (CourseR tid ssh csh CShowR) @@ -4585,7 +4582,7 @@ runSqlPoolRetry :: forall m a backend. => ReaderT backend m a -> Pool backend -> m a -runSqlPoolRetry action pool = do +runSqlPoolRetry action pool = do let policy = Retry.fullJitterBackoff 1e3 & Retry.limitRetriesByCumulativeDelay 10e6 handlers = Retry.skipAsyncExceptions `snoc` Retry.logRetries suggestRetry logRetry where suggestRetry :: IOException -> m Bool @@ -4608,7 +4605,7 @@ runSqlPoolRetry action pool = do runDBRead :: ReaderT SqlReadBackend Handler a -> Handler a runDBRead action = do $logDebugS "YesodPersist" "runDBRead" - runSqlPoolRetry (withReaderT SqlReadBackend action) =<< appConnPool <$> getYesod + runSqlPoolRetry (withReaderT SqlReadBackend action) . appConnPool =<< getYesod -- How to run database actions. instance YesodPersist UniWorX where @@ -4622,7 +4619,7 @@ instance YesodPersist UniWorX where | dryRun = action <* transactionUndo | otherwise = action - runSqlPoolRetry action' =<< appConnPool <$> getYesod + runSqlPoolRetry action' . appConnPool =<< getYesod instance YesodPersistRunner UniWorX where getDBRunner = do @@ -4774,7 +4771,7 @@ upsertCampusUser plugin ldapData = do -- , UserDisplayName =. userDisplayName , UserFirstName =. userFirstName , UserSurname =. userSurname - , UserTitle =. userTitle + , UserTitle =. userTitle , UserEmail =. userEmail , UserSex =. userSex , UserLastLdapSynchronisation =. Just now @@ -4852,7 +4849,7 @@ upsertCampusUser plugin ldapData = do knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] [] let matchingFeatures = case knownParents of [] -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats - ps -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> any (== studyFeaturesField) ps && studyFeaturesSemester == subSemester) unusedFeats + ps -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> elem studyFeaturesField ps && studyFeaturesSemester == subSemester) unusedFeats when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} -> tell $ Set.singleton (subterm, Just studyFeaturesField) if @@ -4911,12 +4908,12 @@ upsertCampusUser plugin ldapData = do insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing oldFs <- selectKeysList - ([ StudyFeaturesUser ==. studyFeaturesUser + [ StudyFeaturesUser ==. studyFeaturesUser , StudyFeaturesDegree ==. studyFeaturesDegree , StudyFeaturesField ==. studyFeaturesField , StudyFeaturesType ==. studyFeaturesType , StudyFeaturesSemester ==. studyFeaturesSemester - ]) + ] [] case oldFs of [oldF] -> update oldF @@ -4933,20 +4930,20 @@ upsertCampusUser plugin ldapData = do associateUserSchoolsByTerms userId let - userAssociatedSchools = fmap concat $ forM userAssociatedSchools' parseLdapSchools + userAssociatedSchools = concat <$> forM userAssociatedSchools' parseLdapSchools userAssociatedSchools' = do (k, v) <- ldapData guard $ k == ldapUserSchoolAssociation v' <- v Right str <- return $ Text.decodeUtf8' v' return str - + ss <- either (throwM . CampusUserInvalidAssociatedSchools . tshow) return userAssociatedSchools forM_ ss $ \frag -> void . runMaybeT $ do let exactMatch = MaybeT . getBy $ UniqueOrgUnit frag - infixMatch = (hoistMaybe . preview _head =<<) . lift . E.select . E.from $ \schoolLdap -> do + infixMatch = (hoistMaybe . preview _head) <=< (lift . E.select . E.from) $ \schoolLdap -> do E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool) return schoolLdap @@ -4960,7 +4957,7 @@ upsertCampusUser plugin ldapData = do } forM_ ss $ void . insertUnique . SchoolLdap Nothing - + return user where insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ()) @@ -5092,7 +5089,7 @@ instance YesodAuth UniWorX where _other -> acceptExisting - authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes + authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool } = catMaybes [ flip campusLogin campusUserFailoverMode <$> appLdapPool , Just . hashLogin $ pwHashAlgorithm appAuthPWHash , dummyLogin <$ guard appAuthDummyLogin @@ -5122,7 +5119,7 @@ campusUserFailoverMode = FailoverUnlimited instance YesodAuthPersist UniWorX where getAuthEntity = liftHandler . runDBRead . get - + unsafeHandler :: UniWorX -> Handler a -> IO a unsafeHandler f h = do logger <- makeLogger f diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index ce5ead5ee..3da033964 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -110,7 +110,7 @@ ordinalEN (toMessage -> numStr) = case lastChar of Just '3' -> [st|#{numStr}rd|] _other -> [st|#{numStr}th|] where - lastChar = last <$> fromNullable numStr + lastChar = last <$> fromNullable numStr -- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers @@ -172,7 +172,7 @@ instance RenderMessage UniWorX MsgLanguage where | ("de" : "DE" : _) <- lang' = mr MsgGermanGermany | ("de" : _) <- lang' = mr MsgGerman | ("en" : "EU" : _) <- lang' = mr MsgEnglishEurope - | ("en" : _) <- lang' = mr MsgEnglish + | ("en" : _) <- lang' = mr MsgEnglish | otherwise = lang where mr = renderMessage foundation $ lang : filter (/= lang) ls @@ -247,7 +247,7 @@ instance RenderMessage UniWorX StudyDegreeTerm where where mr :: RenderMessage UniWorX msg => msg -> Text mr = renderMessage foundation ls - + newtype ShortStudyFieldType = ShortStudyFieldType StudyFieldType embedRenderMessageVariant ''UniWorX ''ShortStudyFieldType ("Short" <>) @@ -333,7 +333,7 @@ instance RenderMessage UniWorX UniWorXMessages where uniworxMessages :: [UniWorXMessage] -> UniWorXMessages uniworxMessages = UniWorXMessages . map SomeMessage - + -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. instance RenderMessage UniWorX FormMessage where diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index afe77ba0e..658f5cf70 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -75,11 +75,11 @@ pattern CSubmissionR tid ssh csh shn cid ptn pattern CApplicationR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> CourseApplicationR -> Route UniWorX pattern CApplicationR tid ssh csh appId ptn = CourseR tid ssh csh (CourseApplicationR appId ptn) - + pattern CNewsR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> CourseNewsR -> Route UniWorX pattern CNewsR tid ssh csh nId ptn = CourseR tid ssh csh (CourseNewsR nId ptn) - + pattern CEventR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseEvent -> CourseEventR -> Route UniWorX pattern CEventR tid ssh csh nId ptn = CourseR tid ssh csh (CourseEventR nId ptn) diff --git a/src/Handler/Admin/StudyFeatures.hs b/src/Handler/Admin/StudyFeatures.hs index 0dfd105b8..f4f40c7fb 100644 --- a/src/Handler/Admin/StudyFeatures.hs +++ b/src/Handler/Admin/StudyFeatures.hs @@ -47,7 +47,7 @@ embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsParents id instance Button UniWorX ButtonAdminStudyTermsParents where btnClasses BtnParentCandidatesInfer = [BCIsButton, BCPrimary] btnClasses BtnParentCandidatesDeleteAll = [BCIsButton, BCDanger] - + data ButtonAdminStudyTermsStandalone = BtnStandaloneCandidatesDeleteRedundant | BtnStandaloneCandidatesDeleteAll @@ -62,7 +62,7 @@ instance Button UniWorX ButtonAdminStudyTermsStandalone where btnClasses BtnStandaloneCandidatesDeleteRedundant = [BCIsButton, BCPrimary] btnClasses BtnStandaloneCandidatesDeleteAll = [BCIsButton, BCDanger] - + {-# ANN postAdminFeaturesR ("HLint: ignore Redundant void" :: String) #-} getAdminFeaturesR, postAdminFeaturesR :: Handler Html getAdminFeaturesR = postAdminFeaturesR @@ -147,7 +147,7 @@ postAdminFeaturesR = do deleteWhere ([] :: [Filter StudyTermStandaloneCandidate]) addMessageI Success MsgAllStandaloneIncidencesDeleted redirect AdminFeaturesR - + newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms badStudyTermKeys <- lookupSessionJson SessionConflictingStudyTerms @@ -208,7 +208,7 @@ postAdminFeaturesR = do infRedundantStandalone <- Candidates.removeRedundantStandalone unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone return updated - + let newKeys = catMaybes $ Map.elems updated unless (null newKeys) $ do setSessionJson SessionNewStudyTerms newKeys @@ -247,19 +247,19 @@ postAdminFeaturesR = do => Lens' a (Maybe Text) -> Getter (DBRow r) (Maybe Text) -> Getter (DBRow r) i - -> DBRow r + -> DBRow r -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) (\row _mkUnique -> bimap (fmap $ set lensRes . assertM (not . Text.null)) fvWidget <$> mopt (textField & cfStrip) "" (Just $ row ^. lensDefault) ) - + checkboxCell :: Ord i => Lens' a Bool -> Getter (DBRow r) Bool -> Getter (DBRow r) i - -> DBRow r - -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) + -> DBRow r + -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) ( \row _mkUnique -> bimap (fmap $ set lensRes) fvWidget <$> mpopt checkBoxField "" (Just $ row ^. lensDefault) @@ -306,7 +306,7 @@ postAdminFeaturesR = do ( \row _mkUnique -> bimap (fmap $ set lensRes) fvWidget <$> mopt degreeField "" (Just $ row ^. lensDefault) ) - + fieldTypeCell :: Ord i => Lens' a (Maybe StudyFieldType) -> Getter (DBRow r) (Maybe StudyFieldType) @@ -359,7 +359,7 @@ postAdminFeaturesR = do fieldSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do E.where_ . E.exists . E.from $ \schoolTerms -> E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId - E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val fId + E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val fId E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools) return $ school E.^. SchoolId fieldParents <- fmap (setOf folded) . E.select . E.from $ \terms -> do diff --git a/src/Handler/Admin/Test/Download.hs b/src/Handler/Admin/Test/Download.hs index a6efc04ef..dc02ae8e0 100644 --- a/src/Handler/Admin/Test/Download.hs +++ b/src/Handler/Admin/Test/Download.hs @@ -45,10 +45,10 @@ testDownloadForm = identifyForm FIDTestDownload . renderWForm FormStandard $ do maxSizeRes <- wreq intField (fslI MsgTestDownloadMaxSize) . Just $ 2 * 2^30 modeRes <- wpopt (selectField optionsFinite) (fslI MsgTestDownloadMode) $ Just TestDownloadDirect - + return $ TestDownloadOptions - <$> pure randomSeed - <*> maxSizeRes + randomSeed + <$> maxSizeRes <*> pure (2^20) <*> modeRes @@ -86,7 +86,7 @@ testDownload = do sourceDBFiles = E.selectSource . E.from $ \fileContent -> do E.orderBy [E.asc $ E.random_ @Int64] return fileContent - + takeLimit n | n <= 0 = return () takeLimit n = do c <- await diff --git a/src/Handler/Admin/Tokens.hs b/src/Handler/Admin/Tokens.hs index 4a9427598..70bb3f9ce 100644 --- a/src/Handler/Admin/Tokens.hs +++ b/src/Handler/Admin/Tokens.hs @@ -30,7 +30,7 @@ bearerTokenForm :: WForm Handler (FormResult BearerTokenForm) bearerTokenForm = do muid <- maybeAuthId mr <- getMessageRender - + btfAuthorityGroups <- aFormToWForm $ HashSet.fromList . map Left <$> massInputListA pathPieceField (const "") MsgBearerTokenAuthorityGroupMissing (\p -> Just . SomeRoute $ AdminTokensR :#: p) ("token-groups" :: Text) (fslI MsgBearerTokenAuthorityGroups & setTooltip MsgBearerTokenAuthorityGroupsTip) False Nothing btfAuthorityUsers <- fmap (fmap . ofoldMap $ HashSet.singleton . Right) <$> wopt (checkMap (foldMapM $ fmap Set.singleton . left MsgBearerTokenAuthorityUnknownUser) (Set.map Right) $ multiUserField False Nothing) (fslpI MsgBearerTokenAuthorityUsers (mr MsgLdapIdentificationOrEmail) & setTooltip MsgBearerTokenAuthorityUsersTip) (Just $ Set.singleton <$> muid) let btfAuthority' :: FormResult (HashSet (Either UserGroupName UserId)) @@ -58,7 +58,7 @@ bearerTokenForm = do miLayout' :: MassInputLayout ListLength (Route UniWorX, Value) (Route UniWorX, Value) miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/token-restrictions/layout") - + btfRestrict' <- fmap HashMap.fromList <$> btfRestrictForm btfAddAuth' <- fmap (assertM $ not . Set.null . dnfTerms) <$> wopt pathPieceField (fslI MsgBearerTokenAdditionalAuth & setTooltip MsgBearerTokenAdditionalAuthTip) Nothing @@ -87,7 +87,7 @@ postAdminTokensR = do & HashSet.map (left toJSON) fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' btfRoutes btfAddAuth btfExpiresAt btfStartsAt - + siteLayoutMsg' MsgMenuAdminTokens $ do setTitleI MsgMenuAdminTokens diff --git a/src/Handler/Allocation/Accept.hs b/src/Handler/Allocation/Accept.hs index 59ea952d2..d6b1c47d3 100644 --- a/src/Handler/Allocation/Accept.hs +++ b/src/Handler/Allocation/Accept.hs @@ -33,7 +33,7 @@ newtype SessionDataAllocationResults = SessionDataAllocationResults deriving (Monoid, Semigroup) via Dual (Map (TermId, SchoolId, AllocationShorthand) (UTCTime, AllocationFingerprint, Set (UserId, CourseId), Seq MatchingLogRun)) makeWrapped ''SessionDataAllocationResults - + data AllocationAcceptButton = BtnAllocationAccept @@ -59,7 +59,7 @@ allocationAcceptForm aId = runMaybeT $ do let applications = E.subSelectCount . E.from $ \courseApplication -> E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.val (Just aId) E.&&. courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser - return . (allocationUser E.^. AllocationUserUser, ) $ E.case_ + return . (allocationUser E.^. AllocationUserUser, ) $ E.case_ [ E.when_ (E.castNum (allocationUser E.^. AllocationUserTotalCourses) E.>. applications) E.then_ (applications :: E.SqlExpr (E.Value Int)) ] @@ -124,7 +124,7 @@ allocationAcceptForm aId = runMaybeT $ do = invDualHeat (optimumAllocated capN) capN degenerateHeat capN = capN <= optimumAllocated capN - + return (prevAllocMatches, $(widgetFile "allocation/accept")) getAAcceptR, postAAcceptR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html @@ -135,7 +135,7 @@ postAAcceptR tid ssh ash = do acceptForm <- maybe (redirect $ AllocationR tid ssh ash AComputeR) return =<< allocationAcceptForm aId - formRes@((acceptRes, _), _) <- liftHandler $ runFormPost acceptForm + formRes@((acceptRes, _), _) <- liftHandler $ runFormPost acceptForm didStore <- formResultMaybe acceptRes $ \(now, allocFp, allocMatchings, allocLog) -> do modifySessionJson SessionAllocationResults . fmap (assertM $ not . views _Wrapped onull) . over (mapped . _Wrapped :: Setter' (Maybe SessionDataAllocationResults) _) $ diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index 73d898959..7f0a6154e 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -58,24 +58,24 @@ data ApplicationFormMode = ApplicationFormMode , afmApplicantEdit :: Bool -- ^ Allow editing text, files, priority (if shown) , afmLecturer :: Bool -- ^ Allow editing rating } - + data ApplicationFormException = ApplicationFormNoApplication -- ^ Could not fill forced fields of application form with data from application deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Exception ApplicationFormException -applicationForm :: (Maybe AllocationId) +applicationForm :: Maybe AllocationId -> CourseId -> UserId -> ApplicationFormMode -- ^ Which parts of the shared form to display -> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView) applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf = do - + (mApp, coursesNum, Course{..}, maxPrio) <- liftHandler . runDB $ do mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1] coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId]) course <- getJust cid - (fromMaybe 0 -> maxPrio) <- fmap ((>>= E.unValue) . listToMaybe) . E.select . E.from $ \courseApplication -> do + (fromMaybe 0 -> maxPrio) <- fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \courseApplication -> do E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority) @@ -91,25 +91,25 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf mkPrioOption :: Natural -> Option Natural mkPrioOption i = Option - { optionDisplay = mr . MsgAllocationCoursePriority $ coursesNum' - i + { optionDisplay = mr . MsgAllocationCoursePriority $ coursesNum' - i , optionInternalValue = i , optionExternalValue = tshow i } - + prioOptions :: OptionList Natural prioOptions = OptionList { olOptions = sortOn (Down . optionInternalValue) . map mkPrioOption $ [0 .. pred coursesNum'] , olReadExternal = readMay } prioField = selectField' (Just $ SomeMessage MsgAllocationCourseNoApplication) $ return prioOptions - + (prioRes, prioView) <- case (isAlloc, afmApplicant, afmApplicantEdit, mApp) of (True , True , True , Nothing) - -> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just $ oldPrio) + -> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just oldPrio) (True , True , True , Just _ ) -> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio (True , True , False, _ ) - -> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio + -> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio (True , False, _ , Just _ ) | is _Just oldPrio -> pure (FormSuccess oldPrio, Nothing) @@ -144,7 +144,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf let appFilesInfo = (,) <$> hasFiles <*> appCID filesLinkView <- if - | fromMaybe False hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit) + | Just True == hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit) -> let filesLinkField = Field{..} where fieldParse _ _ = return $ Right Nothing @@ -165,7 +165,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf -> return Nothing filesWarningView <- if - | fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit + | Just True == hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit -> fmap (Just . snd) . formMessage =<< messageIconI Info IconFileUpload MsgCourseApplicationFilesNeedReupload | otherwise -> return Nothing @@ -174,16 +174,16 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf let mkFs = bool MsgCourseApplicationFile MsgCourseApplicationArchive in if | not afmApplicantEdit || is _NoUpload courseApplicationsFiles - -> return $ (FormSuccess Nothing, Nothing) + -> return (FormSuccess Nothing, Nothing) | otherwise -> fmap (over _2 $ Just . ($ [])) . aFormToForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles (vetoRes, vetoView) <- if | afmLecturer - -> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp) + -> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp) | otherwise - -> return (FormSuccess . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp, Nothing) - + -> return (FormSuccess $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp, Nothing) + (pointsRes, pointsView) <- if | afmLecturer -> over _2 Just <$> mopt examGradeField (fslI MsgApplicationRatingPoints & setTooltip MsgApplicationRatingPointsTip) (fmap Just $ mApp >>= courseApplicationRatingPoints . entityVal) @@ -195,7 +195,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf -> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' (fslI MsgApplicationRatingComment & setTooltip (bool MsgApplicationRatingCommentInvisibleTip MsgApplicationRatingCommentVisibleTip courseApplicationsRatingsVisible)) (fmap Just $ mApp >>= courseApplicationRatingComment . entityVal) | otherwise -> return (FormSuccess $ courseApplicationRatingComment . entityVal =<< mApp, Nothing) - + let buttons = catMaybes [ guardOn (not afmApplicantEdit && is _Just mApp && afmLecturer) BtnAllocationApplicationRate @@ -225,7 +225,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf <*> actionRes , ApplicationFormView { afvPriority = prioView - , afvForm = catMaybes $ + , afvForm = catMaybes $ [ Just fieldView' , textView , filesLinkView @@ -240,7 +240,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf } ) - + editApplicationR :: Maybe AllocationId @@ -285,7 +285,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do , courseApplicationRatingTime = guardOn rated now } - runConduit $ transPipe liftHandler (traverse_ id afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId)) + runConduit $ transPipe liftHandler (sequence_ afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId)) audit $ TransactionCourseApplicationEdit cid uid appId addMessageI Success $ MsgCourseApplicationCreated courseShorthand | is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction @@ -354,7 +354,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do redirect postAction return (appView, appEnc) - + postAApplyR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDCourse -> Handler Void postAApplyR tid ssh ash cID = do diff --git a/src/Handler/Allocation/Compute.hs b/src/Handler/Allocation/Compute.hs index 9c8b300e6..d18b68b31 100644 --- a/src/Handler/Allocation/Compute.hs +++ b/src/Handler/Allocation/Compute.hs @@ -62,7 +62,7 @@ missingPriorities aId = wFormToAForm $ do missingPriosFieldView theId name attrs res isReq = $(i18nWidgetFile "allocation-confirm-missing-prios") where checkBoxFieldView = labeledCheckBoxView (i18n MsgAllocationUsersMissingPrioritiesOk) theId name attrs res isReq - + if | null usersWithoutPrio -> return $ pure Set.empty diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs index fc6d7e48a..549209bf8 100644 --- a/src/Handler/Allocation/List.hs +++ b/src/Handler/Allocation/List.hs @@ -5,7 +5,7 @@ module Handler.Allocation.List ) where import Import - + import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import Handler.Utils.Table.Columns @@ -23,16 +23,16 @@ queryAllocation = id countCourses :: (Num n, PersistField n) - => (E.SqlExpr (Entity AllocationCourse) -> E.SqlExpr (E.Value Bool)) + => (E.SqlExpr (Entity AllocationCourse) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Allocation) -> E.SqlExpr (E.Value n) countCourses addWhere allocation = E.subSelectCount . E.from $ \allocationCourse -> E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId E.&&. addWhere allocationCourse - + queryAvailable :: Getter AllocationTableExpr (E.SqlExpr (E.Value Natural)) queryAvailable = queryAllocation . to (countCourses $ const E.true) - + queryApplied :: UserId -> Getter AllocationTableExpr (E.SqlExpr (E.Value Natural)) queryApplied uid = queryAllocation . to (\allocation -> countCourses (addWhere allocation) allocation) where @@ -51,7 +51,7 @@ resultApplied = _dbrOutput . _3 allocationTermLink :: TermId -> SomeRoute UniWorX allocationTermLink tid = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "term", toPathPiece tid)]) - + allocationSchoolLink :: SchoolId -> SomeRoute UniWorX allocationSchoolLink ssh = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "school", toPathPiece ssh)]) diff --git a/src/Handler/Allocation/Prios.hs b/src/Handler/Allocation/Prios.hs index 20b3f5127..9d5621c1e 100644 --- a/src/Handler/Allocation/Prios.hs +++ b/src/Handler/Allocation/Prios.hs @@ -26,7 +26,7 @@ instance Finite AllocationPrioritiesMode nullaryPathPiece ''AllocationPrioritiesMode $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''AllocationPrioritiesMode id - + getAPriosR, postAPriosR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html getAPriosR = postAPriosR @@ -37,7 +37,7 @@ postAPriosR tid ssh ash = do numericPrios <- E.selectCountRows . E.from $ \allocationUser -> do E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId E.where_ . E.maybe E.false sqlAllocationPriorityNumeric $ allocationUser E.^. AllocationUserPriority - + ordinalPrios <- E.selectCountRows . E.from $ \allocationUser -> do E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId E.where_ . E.maybe E.false (E.not_ . sqlAllocationPriorityNumeric) $ allocationUser E.^. AllocationUserPriority @@ -59,7 +59,7 @@ postAPriosR tid ssh ash = do let sourcePrios = case mode of AllocationPrioritiesNumeric -> transPipe liftHandler fInfo .| fileSourceCsvPositional Csv.NoHeader AllocationPrioritiesOrdinal -> transPipe liftHandler fInfo .| fileSourceCsvPositional Csv.NoHeader .| C.map Csv.fromOnly .| ordinalPriorities - + (matrSunk, matrMissing) <- runDB $ do Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash updateWhere @@ -77,7 +77,7 @@ postAPriosR tid ssh ash = do E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (E.val aId) return (matrSunk, matrMissing) - when (matrSunk > 0) $ + when (matrSunk > 0) $ addMessageI Success $ MsgAllocationPrioritiesSunk matrSunk when (matrMissing > 0) $ addMessageI Error $ MsgAllocationPrioritiesMissing matrMissing diff --git a/src/Handler/Allocation/Register.hs b/src/Handler/Allocation/Register.hs index c502ab48a..9629335c7 100644 --- a/src/Handler/Allocation/Register.hs +++ b/src/Handler/Allocation/Register.hs @@ -46,7 +46,7 @@ postARegisterR tid ssh ash = do formResult registerRes $ \AllocationRegisterForm{..} -> runDB $ do aId <- getKeyBy404 $ TermSchoolAllocationShort tid ssh ash isRegistered <- existsBy $ UniqueAllocationUser aId uid - void $ upsert AllocationUser + void $ upsert AllocationUser { allocationUserAllocation = aId , allocationUserUser = uid , allocationUserTotalCourses = arfTotalCourses @@ -57,5 +57,5 @@ postARegisterR tid ssh ash = do if | isRegistered -> addMessageI Success MsgAllocationRegistrationEdited | otherwise -> addMessageI Success MsgAllocationRegistered - + redirect $ AllocationR tid ssh ash AShowR :#: ("allocation-participation" :: Text) diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 6015f2820..c374501e0 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -4,7 +4,7 @@ module Handler.Allocation.Show import Import import Handler.Utils - + import Handler.Allocation.Register import Handler.Allocation.Application diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs index 08260f683..e150f1d1b 100644 --- a/src/Handler/Allocation/Users.hs +++ b/src/Handler/Allocation/Users.hs @@ -63,11 +63,11 @@ type UserTableData = DBRow ( Entity User , Int -- ^ Applied , Int -- ^ Assigned , Int -- ^ Vetoed - ) + ) resultUser :: Lens' UserTableData (Entity User) resultUser = _dbrOutput . _1 - + resultAllocationUser :: Lens' UserTableData (Entity AllocationUser) resultAllocationUser = _dbrOutput . _2 @@ -83,7 +83,7 @@ data AllocationUserTableCsv = AllocationUserTableCsv , csvAUserName :: Text , csvAUserMatriculation :: Maybe Text , csvAUserRequested - , csvAUserApplied + , csvAUserApplied , csvAUserVetos , csvAUserAssigned :: Natural , csvAUserPriority :: Maybe AllocationPriority @@ -94,10 +94,10 @@ allocationUserTableCsvOptions :: Csv.Options allocationUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3} instance Csv.ToNamedRecord AllocationUserTableCsv where - toNamedRecord = Csv.genericToNamedRecord allocationUserTableCsvOptions + toNamedRecord = Csv.genericToNamedRecord allocationUserTableCsvOptions instance Csv.DefaultOrdered AllocationUserTableCsv where - headerOrder = Csv.genericHeaderOrder allocationUserTableCsvOptions + headerOrder = Csv.genericHeaderOrder allocationUserTableCsvOptions instance CsvColumnsExplained AllocationUserTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations allocationUserTableCsvOptions $ mconcat diff --git a/src/Handler/Course/Application/Files.hs b/src/Handler/Course/Application/Files.hs index c608aa94e..05b229560 100644 --- a/src/Handler/Course/Application/Files.hs +++ b/src/Handler/Course/Application/Files.hs @@ -42,7 +42,7 @@ getCAppsFilesR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent getCAppsFilesR tid ssh csh = do runDB . existsBy404 $ TermSchoolCourseShort tid ssh csh MsgRenderer mr <- getMsgRenderer - + archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh let @@ -61,12 +61,12 @@ getCAppsFilesR tid ssh csh = do hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR let applicationAllocs = setOf (folded . _1) apps' - + allocations = applicationAllocs ^.. folded . _Just . _entityVal . $(multifocusG 3) _allocationTerm _allocationSchool _allocationShorthand allEqualOn :: Eq x => Getter _ x -> Bool allEqualOn l = maybe True (\x -> allOf (folded . l) (== x) allocations) (allocations ^? _head . l) - + mkAllocationDir mbAlloc | not $ allEqualOn _1 , Just Allocation{..} <- mbAlloc @@ -92,7 +92,7 @@ getCAppsFilesR tid ssh csh = do fileEntitySource = E.selectSource . E.from $ \courseApplicationFile -> do E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId return courseApplicationFile - + yield $ _FileReference # ( FileReference { fileReferenceModified = courseApplicationTime , fileReferenceTitle = mkAppDir "" diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 6a98c7e48..b2b7200b4 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -47,7 +47,7 @@ type CourseApplicationsTableData = DBRow ( Entity CourseApplication , Maybe (Entity StudyDegree) , Bool -- isParticipant ) - + courseApplicationsIdent :: Text courseApplicationsIdent = "applications" @@ -120,7 +120,7 @@ instance Csv.FromField CourseApplicationsTableVeto where (CI.map Text.strip -> t :: CI Text) <- Csv.parseField f return . CourseApplicationsTableVeto $ elem t [ "veto", "v", "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ] - + data CourseApplicationsTableCsv = CourseApplicationsTableCsv { csvCAAllocation :: Maybe AllocationShorthand , csvCAApplication :: Maybe CryptoFileNameCourseApplication @@ -223,7 +223,7 @@ instance Exception CourseApplicationsTableCsvException embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvException id - + data ButtonAcceptApplications = BtnAcceptApplications deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonAcceptApplications @@ -277,7 +277,7 @@ postCApplicationsR tid ssh csh = do applicationLink appId = liftHandler $ do cID <- encrypt appId return . SomeRoute $ CApplicationR tid ssh csh cID CAEditR - + dbtSQLQuery :: CourseApplicationsTableExpr -> E.SqlQuery _ dbtSQLQuery = runReaderT $ do courseApplication <- view queryCourseApplication @@ -415,13 +415,13 @@ postCApplicationsR tid ssh csh = do -> return () -- no addition DBCsvDiffExisting{..} -> do let appId = dbCsvOld ^. resultCourseApplication . _entityKey - + newFeatures <- lift $ lookupStudyFeatures dbCsvNew when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ yield $ CourseApplicationsTableCsvSetFieldData appId newFeatures let mVeto = dbCsvNew ^? _csvCAVeto . _Just . _CourseApplicationsTableVeto - whenIsJust mVeto $ \veto -> + whenIsJust mVeto $ \veto -> when (veto /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingVeto) $ yield $ CourseApplicationsTableCsvSetVetoData appId veto @@ -638,7 +638,7 @@ postCApplicationsR tid ssh csh = do let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle registrationOpen = maybe True (now <) - + ((acceptRes, acceptWgt'), acceptEnc) <- runFormPost . identifyForm BtnAcceptApplications . renderAForm FormStandard $ (,) <$> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsMode & setTooltip MsgAcceptApplicationsModeTip) (Just AcceptApplicationsInvite) <*> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsSecondary & setTooltip MsgAcceptApplicationsSecondaryTip) (Just AcceptApplicationsSecondaryTime) @@ -679,7 +679,7 @@ postCApplicationsR tid ssh csh = do AcceptApplicationsSecondaryRandom -> comparing $ view ratingL sortedApplications <- unstableSortBy cmp applications - + let applicants = sortedApplications & nubOn (view $ _1 . _entityKey) & maybe id take openCapacity @@ -687,7 +687,7 @@ postCApplicationsR tid ssh csh = do AcceptApplicationsDirect -> folded . _1 . _entityKey . to Right AcceptApplicationsInvite -> folded . _1 . _entityVal . _userEmail . to Left ) - + mapM_ addMessage' <=< execWriterT $ registerUsers cid applicants redirect $ CourseR tid ssh csh CUsersR diff --git a/src/Handler/Course/Communication.hs b/src/Handler/Course/Communication.hs index dd833eccd..005aca3ae 100644 --- a/src/Handler/Course/Communication.hs +++ b/src/Handler/Course/Communication.hs @@ -94,7 +94,7 @@ postCCommR tid ssh csh = do E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val cid E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - return user + return user ) ] ++ tuts ++ exams ++ sheets , crRecipientAuth = Just $ \uid -> do diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 8ba44473e..2bc825445 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -88,7 +88,7 @@ courseToForm cEnt@(Entity cid Course{..}) lecs lecInvites alloc = CourseForm where selectAppFiles = E.selectSource . E.from $ \courseAppInstructionFile -> do E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid return courseAppInstructionFile - + allocationCourseToForm :: Entity Course -> Entity AllocationCourse -> AllocationCourseForm allocationCourseToForm (Entity _ Course{..}) (Entity _ AllocationCourse{..}) = AllocationCourseForm @@ -134,7 +134,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB , not $ Set.null existing -> FormFailure [mr MsgCourseLecturerAlreadyAdded] | otherwise - -> FormSuccess . Map.fromList . zip [maybe 0 succ . fmap fst $ Map.lookupMax oldDat ..] $ Set.toList newDat + -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat addView' = $(widgetFile "course/lecturerMassInput/add") return (addRes'', addView') @@ -194,9 +194,9 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing) _allIOtherCases -> do mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName] - return ( (Just . toMidnight . termStart . entityVal) <$> mbLastTerm - , (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm - , (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm ) + return ( Just . toMidnight . termStart . entityVal <$> mbLastTerm + , Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm + , Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm ) let allocationForm :: AForm Handler (Maybe AllocationCourseForm) @@ -208,7 +208,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB E.exists . E.from $ \allocationCourse -> E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cid E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId - + E.where_ $ term E.^. TermActive E.||. alreadyParticipates E.||. allocation E.^. AllocationSchool `E.in_` E.valList adminSchools @@ -238,8 +238,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB let userAdmin = not $ null adminSchools - mayChange = fromMaybe True $ (|| userAdmin) <$> currentAllocationAvailable - + mayChange = Just False /= fmap (|| userAdmin) currentAllocationAvailable + allocationForm' = let ainp :: Field Handler a -> FieldSettings UniWorX -> Maybe a -> AForm Handler a ainp @@ -260,8 +260,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm - <$> pure (cfCourseId =<< template) - <*> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template) + (cfCourseId =<< template) + <$> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template) <*> areq (textField & cfStrip & cfCI) (fslpI MsgCourseShorthand "ProMo, LinAlg1, AlgoDat, Ana2, EiP, …" -- & addAttr "disabled" "disabled" & setTooltip MsgCourseShorthandUnique) (cfShort <$> template) @@ -322,7 +322,7 @@ validateCourse = do guardValidation MsgCourseRegistrationEndMustBeAfterStart $ NTop cfRegFrom <= NTop cfRegTo guardValidation MsgCourseDeregistrationEndMustBeAfterStart - $ fromMaybe True $ (<=) <$> cfRegFrom <*> cfDeRegUntil + $ Just False /= ((<=) <$> cfRegFrom <*> cfDeRegUntil) unless userAdmin $ guardValidation MsgCourseUserMustBeLecturer $ anyOf (traverse . _Right . _1) (== uid) cfLecturers @@ -335,7 +335,7 @@ validateCourse = do warnValidation MsgCourseShorthandTooLong $ length (CI.original cfShort) <= 10 - + getCourseNewR :: Handler Html -- call via toTextUrl getCourseNewR = do @@ -521,7 +521,7 @@ courseEditHandler miButtonAction mbCourseForm = do insert_ $ CourseEdit aid now cid let mkFilter CourseAppInstructionFileResidual{..} = [ CourseAppInstructionFileCourse ==. courseAppInstructionFileResidualCourse ] - in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . traverse_ id $ cfAppInstructionFiles res + in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . sequence_ $ cfAppInstructionFiles res upsertAllocationCourse cid $ cfAllocation res diff --git a/src/Handler/Course/Events/Delete.hs b/src/Handler/Course/Events/Delete.hs index 609fa93a5..3dd5d06fb 100644 --- a/src/Handler/Course/Events/Delete.hs +++ b/src/Handler/Course/Events/Delete.hs @@ -8,13 +8,13 @@ import Handler.Utils.Occurrences import Handler.Utils.Delete import qualified Data.Set as Set - + getCEvDeleteR, postCEvDeleteR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseEvent -> Handler Html getCEvDeleteR = postCEvDeleteR postCEvDeleteR tid ssh csh cID = do nId <- decrypt cID - + let drRecords :: Set (Key CourseEvent) drRecords = Set.singleton nId @@ -31,23 +31,23 @@ postCEvDeleteR tid ssh csh cID = do : ^{occurrencesWidget courseEventTime} |] - + drRecordConfirmString :: Entity CourseEvent -> DB Text drRecordConfirmString _ = return "" - + drCaption, drSuccessMessage :: SomeMessage UniWorX drCaption = SomeMessage MsgCourseEventDeleteQuestion drSuccessMessage = SomeMessage MsgCourseEventDeleted - + drAbort, drSuccess :: SomeRoute UniWorX drAbort = SomeRoute $ CourseR tid ssh csh CShowR :#: [st|event-#{toPathPiece cID}|] drSuccess = SomeRoute $ CourseR tid ssh csh CShowR - + drFormMessage :: [Entity CourseEvent] -> DB (Maybe Message) drFormMessage _ = return Nothing - + drDelete :: forall a. CourseEventId -> JobDB a -> JobDB a drDelete _ = id - + deleteR DeleteRoute{..} diff --git a/src/Handler/Course/Events/Edit.hs b/src/Handler/Course/Events/Edit.hs index 5ac391d5d..0dcfaa30a 100644 --- a/src/Handler/Course/Events/Edit.hs +++ b/src/Handler/Course/Events/Edit.hs @@ -4,7 +4,7 @@ module Handler.Course.Events.Edit import Import import Handler.Utils - + import Handler.Course.Events.Form diff --git a/src/Handler/Course/Events/Form.hs b/src/Handler/Course/Events/Form.hs index 3cb291f89..ecc01b8e9 100644 --- a/src/Handler/Course/Events/Form.hs +++ b/src/Handler/Course/Events/Form.hs @@ -31,7 +31,7 @@ courseEventForm template = identifyForm FIDCourseEvent . renderWForm FormStandar ) let courseEventTypes = optionsPairs [ (courseEventType, courseEventType) | Entity _ CourseEvent{..} <- existingEvents ] courseEventRooms = optionsPairs [ (courseEventRoom, courseEventRoom) | Entity _ CourseEvent{..} <- existingEvents ] - + cefType' <- wreq (textField & cfStrip & cfCI & addDatalist courseEventTypes) (fslI MsgCourseEventType & addPlaceholder (mr MsgCourseEventTypePlaceholder)) (cefType <$> template) cefRoom' <- wreq (textField & cfStrip & addDatalist courseEventRooms) (fslI MsgCourseEventRoom) (cefRoom <$> template) cefTime' <- aFormToWForm $ occurrencesAForm ("time" :: Text) (cefTime <$> template) diff --git a/src/Handler/Course/Events/New.hs b/src/Handler/Course/Events/New.hs index b01f17af5..b389de9de 100644 --- a/src/Handler/Course/Events/New.hs +++ b/src/Handler/Course/Events/New.hs @@ -4,7 +4,7 @@ module Handler.Course.Events.New import Import import Handler.Utils - + import Handler.Course.Events.Form getCEventsNewR, postCEventsNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html diff --git a/src/Handler/Course/News/Delete.hs b/src/Handler/Course/News/Delete.hs index 2311f9335..8fda2c3a0 100644 --- a/src/Handler/Course/News/Delete.hs +++ b/src/Handler/Course/News/Delete.hs @@ -12,7 +12,7 @@ getCNDeleteR, postCNDeleteR :: TermId -> SchoolId -> CourseShorthand -> CryptoUU getCNDeleteR = postCNDeleteR postCNDeleteR tid ssh csh cID = do nId <- decrypt cID - + let drRecords :: Set (Key CourseNews) drRecords = Set.singleton nId @@ -26,22 +26,22 @@ postCNDeleteR tid ssh csh cID = do [ toWidget <$> courseNewsTitle , toWidget <$> courseNewsSummary ] - + drRecordConfirmString :: Entity CourseNews -> DB Text drRecordConfirmString _ = return "" - + drCaption, drSuccessMessage :: SomeMessage UniWorX drCaption = SomeMessage MsgCourseNewsDeleteQuestion drSuccessMessage = SomeMessage MsgCourseNewsDeleted - + drAbort, drSuccess :: SomeRoute UniWorX drAbort = SomeRoute $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|] drSuccess = SomeRoute $ CourseR tid ssh csh CShowR drFormMessage :: [Entity CourseNews] -> DB (Maybe Message) drFormMessage _ = return Nothing - + drDelete :: forall a. CourseNewsId -> JobDB a -> JobDB a drDelete _ = id - + deleteR DeleteRoute{..} diff --git a/src/Handler/Course/News/Download.hs b/src/Handler/Course/News/Download.hs index b898c7f7f..59cfaabe8 100644 --- a/src/Handler/Course/News/Download.hs +++ b/src/Handler/Course/News/Download.hs @@ -25,7 +25,7 @@ getCNArchiveR tid ssh csh cID = do serveSomeFiles archiveName getFilesQuery - + getCNFileR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> FilePath -> Handler TypedContent getCNFileR _ _ _ cID title = do nId <- decrypt cID diff --git a/src/Handler/Course/News/Edit.hs b/src/Handler/Course/News/Edit.hs index 14c30f7b2..cf4f4377a 100644 --- a/src/Handler/Course/News/Edit.hs +++ b/src/Handler/Course/News/Edit.hs @@ -34,7 +34,7 @@ postCNEditR tid ssh csh cID = do , courseNewsLastEdit = now } let mkFilter CourseNewsFileResidual{} = [ CourseNewsFileNews ==. nId ] - in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ traverse_ id cnfFiles + in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ sequence_ cnfFiles addMessageI Success MsgCourseNewsEdited redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|] diff --git a/src/Handler/Course/News/Form.hs b/src/Handler/Course/News/Form.hs index 0d52e3001..5d5aeb599 100644 --- a/src/Handler/Course/News/Form.hs +++ b/src/Handler/Course/News/Form.hs @@ -16,7 +16,7 @@ data CourseNewsForm = CourseNewsForm , cnfContent :: Html , cnfParticipantsOnly :: Bool , cnfVisibleFrom :: Maybe UTCTime - , cnfFiles :: Maybe FileUploads + , cnfFiles :: Maybe FileUploads } courseNewsForm :: Maybe CourseNewsForm -> Form CourseNewsForm diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index f461816b8..dab5b62e2 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -96,7 +96,7 @@ participantInvitationConfig = InvitationConfig{..} now <- liftIO getCurrentTime studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing - return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive + return . fmap (, ()) $ JunctionParticipant now <$> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive invitationInsertHook _ _ (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert res <- act -- insertUnique @@ -138,7 +138,7 @@ postCAddUserR tid ssh csh = do formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ hoist runDBJobs . registerUsers' cid - + let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading @@ -169,7 +169,7 @@ addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => AddParticipantsResult -> ReaderT (YesodPersistBackend UniWorX) m [Message] addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do - (aurAlreadyRegistered', aurNoUniquePrimaryField') <- + (aurAlreadyRegistered', aurNoUniquePrimaryField') <- (,) <$> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered) <*> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurNoUniquePrimaryField) diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index 139af8444..117f99b38 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -63,7 +63,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do isRegistered = btn `elem` [BtnCourseRetractApplication, BtnCourseDeregister] return . (, btn) . wFormToAForm $ do MsgRenderer mr <- getMsgRenderer - + secretRes <- if | Just secret <- courseRegisterSecret , not isRegistered @@ -112,7 +112,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do let appFilesInfo = (,) <$> hasFiles <*> appCID filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired - when (isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles) $ + when (isn't _NoUpload courseApplicationsFiles || Just True == hasFiles) $ let filesLinkField = Field{..} where fieldParse _ _ = return $ Right Nothing @@ -130,7 +130,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do |] in void $ wforced filesLinkField (fslI filesMsg) Nothing - when (fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles) $ + when (Just True == hasFiles && isn't _NoUpload courseApplicationsFiles) $ wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive @@ -145,14 +145,14 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do wformMessage =<< messageIconI Warning IconExamRegisterFalse MsgCourseDeregistrationAllocationLog when (is _Just (registration >>= courseParticipantAllocated . entityVal) && courseDeregisterNoShow) $ wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoShow - + return $ CourseRegisterForm <$ secretRes <*> fieldRes <*> appTextRes <*> appFilesRes - + -- | Workaround for klicking register button without being logged in. -- After log in, the user sees a "get request not supported" error. getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html @@ -193,8 +193,8 @@ postCRegisterR tid ssh csh = do return $ Just prevId - whenIsJust appRes $ - audit . TransactionCourseApplicationEdit cid uid + whenIsJust appRes $ + audit . TransactionCourseApplicationEdit cid uid whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do runConduit $ transPipe liftHandler fSource .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId)) return appRes @@ -275,7 +275,7 @@ deregisterParticipant uid cid = do forM_ examRegistrations $ \(Entity erId ExamRegistration{..}) -> do delete erId audit $ TransactionExamDeregister examRegistrationExam uid - + E.delete . E.from $ \tutorialParticipant -> do let tutorialCourse = E.subSelectForeign tutorialParticipant TutorialParticipantTutorial (E.^. TutorialCourse) diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index d8cd57425..0ea29fc68 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -103,16 +103,15 @@ getCShowR tid ssh csh = do E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid return $ submissionGroup E.^. SubmissionGroupName let submissionGroup = guardOnM (hasSubmissionGroups && is _Just registration) submissionGroup' - + return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup) let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course - mDereg <- traverse (formatTime SelFormatDateTime) mDereg' + mDereg <- traverse (formatTime SelFormatDateTime) mDereg' cID <- encrypt cid :: Handler CryptoUUIDCourse - mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (,) - <$> pure alloc - <*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID) + mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (alloc, ) + <$> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID) regForm <- if | is _Just mbAid -> do (courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course) @@ -125,9 +124,9 @@ getCShowR tid ssh csh = do | otherwise -> return . modal $(widgetFile "course/login-to-register") . Left . SomeRoute $ AuthR LoginR registrationOpen <- hasWriteAccessTo $ CourseR tid ssh csh CRegisterR - + MsgRenderer mr <- getMsgRenderer - + let tutorialDBTable = DBTable{..} where diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 690d02099..e7ad89d12 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -60,7 +60,7 @@ postCUserR tid ssh csh uCId = do registered <- exists [ CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive ] return (course, Entity uid user, registered) - + sections <- mapM (runMaybeT . ($ user) . ($ course)) [ courseUserProfileSection , courseUserNoteSection @@ -202,11 +202,11 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = return $(widgetFile "course/user/profile") - + courseUserNoteSection :: Entity Course -> Entity User -> MaybeT Handler Widget courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CUsersR - + currentRoute <- MaybeT getCurrentRoute (thisUniqueNote, noteText, noteEdits) <- lift . runDB $ do @@ -306,7 +306,7 @@ courseUserExamsSection (Entity cid Course{..}) (Entity uid _) = do guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CExamNewR uCID <- encrypt uid - + let examDBTable = DBTable{..} where diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index f7454ab38..c685164e2 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -137,7 +137,7 @@ _userSheets = _dbrOutput . _8 colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) colUserComment tid ssh csh = - sortable (Just "note") (i18nCell MsgCourseUserNote) $ views (_dbrOutput . $(multifocusG 2) (_1 . _entityKey) _3) $ \(uid, mbNoteKey) -> + sortable (Just "note") (i18nCell MsgCourseUserNote) $ views (_dbrOutput . $(multifocusG 2) (_1 . _entityKey) _3) $ \(uid, mbNoteKey) -> maybeEmpty mbNoteKey $ const $ anchorCellM (courseLink <$> encrypt uid) (hasComment True) where @@ -189,15 +189,15 @@ colUserSubmissionGroup = sortable (Just "submission-group") (i18nCell MsgSubmiss colUserSheets :: forall m c. IsDBTable m c => [SheetName] -> Cornice Sortable ('Cap 'Base) UserTableData (DBCell m c) colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns where - caption = i18nCell MsgCourseUserSheets + caption = i18nCell MsgCourseUserSheets & cellAttrs <>~ [ ("uw-hide-column-header", "sheets") , ("uw-hide-column-default-hidden", "") ] - + userSheetCol :: SheetName -> Colonnade Sortable UserTableData (DBCell m c) userSheetCol shn = sortable (Just . SortingKey $ "sheet-" <> shn) (i18nCell shn) . views (_userSheets . at shn) $ \case Just (preview _grading -> Just Points{..}, Just points) -> i18nCell $ MsgAchievedOf points maxPoints - Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgNotPassed MsgPassed . fromMaybe False $ gradingPassed grading' points + Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgNotPassed MsgPassed $ Just True == gradingPassed grading' points _other -> mempty @@ -208,7 +208,7 @@ data UserTableCsvStudyFeature = UserTableCsvStudyFeature , csvUserType :: StudyFieldType } deriving (Eq, Ord, Read, Show, Generic, Typeable) makeLenses_ ''UserTableCsvStudyFeature - + data UserTableCsv = UserTableCsv { csvUserName :: Text , csvUserSex :: Maybe Sex @@ -387,33 +387,33 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do , single $ sortUserEmail queryUser , single $ sortUserMatriclenr queryUser , sortUserSex (to queryUser . to (E.^. UserSex)) - , single $ ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName)) - , single $ ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)) - , single $ ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName)) - , single $ ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) - , single $ ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) - , single $ ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration)) - , single $ ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date + , single ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName)) + , single ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)) + , single ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName)) + , single ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) + , single ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) + , single ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration)) + , single ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date E.subSelectMaybe . E.from $ \edit -> do E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) return . E.max_ $ edit E.^. CourseUserNoteEditTime ) - , single $ ("tutorials" , SortColumn $ queryUser >>> \user -> + , single ("tutorials" , SortColumn $ queryUser >>> \user -> E.subSelectMaybe . E.from $ \(tutorial `E.InnerJoin` participant) -> do E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial E.&&. tutorial E.^. TutorialCourse E.==. E.val cid E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId return . E.min_ $ tutorial E.^. TutorialName ) - , single $ ("exams" , SortColumn $ queryUser >>> \user -> + , single ("exams" , SortColumn $ queryUser >>> \user -> E.subSelectMaybe . E.from $ \(exam `E.InnerJoin` examRegistration) -> do E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam E.&&. exam E.^. ExamCourse E.==. E.val cid E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId return . E.min_ $ exam E.^. ExamName ) - , single $ ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName)) - , single $ ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState)) + , single ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName)) + , single ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState)) , mconcat [ single ( SortingKey $ "sheet-" <> sheetName , SortColumn $ \(queryUser -> user) -> E.subSelectMaybe . E.from $ \(submission `E.InnerJoin` submissionUser) -> do @@ -421,8 +421,8 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.where_ $ submission E.^. SubmissionSheet E.==. E.val shId return $ submission E.^. SubmissionRatingPoints - - ) + + ) | Entity shId Sheet{..} <- sheets ] ] @@ -433,38 +433,38 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do , single $ fltrUserMatriclenr queryUser , single $ fltrUserNameEmail queryUser , fltrUserSex (to queryUser . to (E.^. UserSex)) - , single $ ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName)) - , single $ ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) - , single $ ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey)) - , single $ ("field" , FilterColumn $ E.anyFilter + , single ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName)) + , single ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) + , single ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey)) + , single ("field" , FilterColumn $ E.anyFilter [ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName) , E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand) , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey) ] ) - , single $ ("degree" , FilterColumn $ E.anyFilter + , single ("degree" , FilterColumn $ E.anyFilter [ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName) , E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand) , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey) ] ) - , single $ ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) - , single $ ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion -> + , single ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) + , single ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion -> E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId ) - , single $ ("exam" , FilterColumn $ E.mkExistsFilter $ \row criterion -> + , single ("exam" , FilterColumn $ E.mkExistsFilter $ \row criterion -> E.from $ \(exam `E.InnerJoin` examRegistration) -> do E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam E.where_ $ exam E.^. ExamCourse E.==. E.val cid E.&&. E.hasInfix (exam E.^. ExamName) (E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.&&. examRegistration E.^. ExamRegistrationUser E.==.queryUser row E.^. UserId ) - -- , ("course-registration", error "TODO") -- TODO - -- , ("course-user-note", error "TODO") -- TODO - , single $ ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName)) - , single $ ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState)) + + + , single ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName)) + , single ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState)) ] where single = uncurry Map.singleton dbtFilterUI mPrev = mconcat $ @@ -498,7 +498,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do { dbtCsvExportForm = UserCsvExportData <$> apopt checkBoxField (fslI MsgUserSimplifiedFeaturesOfStudyCsv & setTooltip MsgUserSimplifiedFeaturesOfStudyCsvTip) (Just $ csvUserSimplifiedFeaturesOfStudy def) <*> apopt checkBoxField (fslI MsgCourseUserCsvIncludeSheets & setTooltip MsgCourseUserCsvIncludeSheetsTip) (Just $ csvUserIncludeSheets def) - , dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $ + , dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $ UserTableCsv <$> view (hasUser . _userDisplayName) <*> view (hasUser . _userSex) @@ -615,7 +615,7 @@ postCUsersR tid ssh csh = do hasExams = not $ null exams examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId)) examOccActs = examOccurrencesPerExam - & (map (bimap entityKey hoistMaybe)) + & map (bimap entityKey hoistMaybe) & Map.fromListWith (<>) & imap (\k v -> case v of [] -> pure (k, Nothing) @@ -684,7 +684,7 @@ postCUsersR tid ssh csh = do addMessageI Success $ MsgCourseUsersDeregistered nrDel redirect $ CourseR tid ssh csh CUsersR (CourseUserRegisterTutorialData{..}, selectedUsers) -> do - runDB . forM_ selectedUsers $ + runDB . forM_ selectedUsers $ void . insertUnique . TutorialParticipant registerTutorial addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers redirect $ CourseR tid ssh csh CUsersR @@ -725,7 +725,7 @@ postCUsersR tid ssh csh = do ] [ CourseParticipantState =. CourseParticipantActive , CourseParticipantRegistration =. now - , CourseParticipantAllocated =. Nothing + , CourseParticipantAllocated =. Nothing ] guard $ didUpdate > 0 lift $ deleteWhere [ AllocationDeregisterCourse ==. Just cid, AllocationDeregisterUser ==. uid ] diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index 66c152c9f..2dbfece2a 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -62,7 +62,7 @@ instance (CryptoRoute ciphertext plaintext, Dispatch ciphertext ps) => Dispatch handleCryptoID :: CryptoIDError -> Handler (Maybe a) handleCryptoID _ = return Nothing dispatchTail = dispatchID (Proxy :: Proxy ps) ciphertext - + getCryptoUUIDDispatchR :: UUID -> Handler () getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectAccessWith movedPermanently301) @@ -75,5 +75,5 @@ getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectAcce getCryptoFileNameDispatchR :: CI FilePath -> Handler () getCryptoFileNameDispatchR path = dispatchID p path >>= maybe notFound (redirectAccessWith movedPermanently301) where - p :: Proxy '[ SubmissionId ] + p :: Proxy '[ SubmissionId ] p = Proxy diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs index aeef1facc..912e52054 100644 --- a/src/Handler/Exam/AddUser.hs +++ b/src/Handler/Exam/AddUser.hs @@ -8,15 +8,15 @@ import Handler.Exam.RegistrationInvite import Handler.Utils import Handler.Utils.Exam import Handler.Utils.Invitations - + import qualified Data.Set as Set import Data.Semigroup (Option(..)) - + import Control.Monad.Error.Class (MonadError(..)) import Jobs.Queue - + import Generics.Deriving.Monoid @@ -43,7 +43,7 @@ postEAddUserR tid ssh csh examn = do ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do now <- liftIO getCurrentTime occurrences <- liftHandler . runDB $ selectList [ExamOccurrenceExam ==. eid] [] - + let localNow = utcToLocalTime now tomorrowEndOfDay = case localTimeToUTC (LocalTime (addDays 2 $ localDay localNow) midnight) of @@ -65,7 +65,7 @@ postEAddUserR tid ssh csh examn = do = max tomorrowEndOfDay earliestDate' | otherwise = tomorrowEndOfDay - + deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline) enlist <- wpopt checkBoxField (fslI MsgExamRegistrationEnlistDirectly & setTooltip MsgExamRegistrationEnlistDirectlyTip) (Just False) registerCourse <- wpopt checkBoxField (fslI MsgExamRegistrationRegisterCourse & setTooltip MsgExamRegistrationRegisterCourseTip) (Just False) @@ -132,7 +132,7 @@ postEAddUserR tid ssh csh examn = do lift $ lift examRegister throwError $ mempty { aurSuccess = pure userEmail } - unless registerCourse $ + unless registerCourse $ throwError $ mempty { aurNoCourseRegistration = pure userEmail } guardAuthResult =<< lift (lift $ evalAccessDB (CourseR tid ssh csh CAddUserR) True) diff --git a/src/Handler/Exam/AutoOccurrence.hs b/src/Handler/Exam/AutoOccurrence.hs index 1f38a7910..7f135b552 100644 --- a/src/Handler/Exam/AutoOccurrence.hs +++ b/src/Handler/Exam/AutoOccurrence.hs @@ -52,7 +52,7 @@ examAutoOccurrenceCalculateForm :: ExamAutoOccurrenceCalculateForm -> Form ExamA examAutoOccurrenceCalculateForm ExamAutoOccurrenceCalculateForm{ eaofConfig } = identifyForm FIDExamAutoOccurrenceCalculate . renderAForm FormStandard $ ExamAutoOccurrenceCalculateForm <$> eaocForm where - eaocForm = + eaocForm = (set _eaocMinimizeRooms <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just $ eaofConfig ^. _eaocMinimizeRooms)) <*> pure def @@ -62,7 +62,7 @@ examAutoOccurrenceNudgeForm occId protoForm html = do (btnRes, wgt) <- identifyForm (FIDExamAutoOccurrenceNudge $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceNudgeUp, BtnExamAutoOccurrenceNudgeDown]) html oldDataRes <- globalPostParamField PostExamAutoOccurrencePrevious secretJsonField oldDataId <- newIdent - + let protoForm' = fromMaybe def $ oldDataRes <|> protoForm genForm btn = protoForm' & _eaofConfig . _eaocNudge %~ Map.insertWith (+) occId n where n = case btn of @@ -83,12 +83,12 @@ examAutoOccurrenceAcceptForm confirmData = identifyForm FIDExamAutoOccurrenceCon examAutoOccurrenceCalculateWidget :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Widget examAutoOccurrenceCalculateWidget tid ssh csh examn = do (formView, formEncoding) <- liftHandler . generateFormPost $ examAutoOccurrenceCalculateForm def - + wrapForm' BtnExamAutoOccurrenceCalculate $(i18nWidgetFile "exam-auto-occurrence-calculate") def { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR , formEncoding } - + postEAutoOccurrenceR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html postEAutoOccurrenceR tid ssh csh examn = do @@ -96,8 +96,8 @@ postEAutoOccurrenceR tid ssh csh examn = do exam@(Entity eId _) <- fetchExam tid ssh csh examn occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [ Asc ExamOccurrenceName ] return (exam, occurrences) - - + + ((calculateRes, _), _) <- runFormPost $ examAutoOccurrenceCalculateForm def nudgeRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId -> diff --git a/src/Handler/Exam/Correct.hs b/src/Handler/Exam/Correct.hs index 7e85169c9..2f66d8903 100644 --- a/src/Handler/Exam/Correct.hs +++ b/src/Handler/Exam/Correct.hs @@ -84,15 +84,15 @@ getECorrectR tid ssh csh examn = do return (exam, entityVal <$> examParts) mayEditResults <- hasWriteAccessTo $ CExamR tid ssh csh examn EUsersR - + let heading = prependCourseTitle tid ssh csh $ (mr . MsgExamCorrectHeading . CI.original) examName - + ptsInput :: ExamPartNumber -> Widget ptsInput n = do name <- newIdent fieldView (pointsField :: Field Handler Points) ("exam-correct__" <> toPathPiece n) name [("uw-exam-correct--part-input", toPathPiece n)] (Left "") False - + examGrades :: [ExamGrade] examGrades = universeF @@ -111,12 +111,12 @@ postECorrectR tid ssh csh examn = do CorrectInterfaceRequest{..} <- requireCheckJsonBody mayEditResults <- hasWriteAccessTo $ CExamR tid ssh csh examn EUsersR - + response <- runDB . exceptT (<$ transactionUndo) return $ do Entity eId Exam{} <- lift $ fetchExam tid ssh csh examn euid <- traverse decrypt ciqUser - guardMExceptT (maybe True ((>= 3) . length) $ euid ^? _Left) $ + guardMExceptT (maybe True ((>= 3) . length) $ euid ^? _Left) $ CorrectInterfaceResponseFailure Nothing <$> (getMessageRender <*> pure MsgExamCorrectErrorNeedleTooShort) @@ -188,7 +188,7 @@ postECorrectR tid ssh csh examn = do in CorrectInterfaceResponseFailure <$> (Just <$> userToResponse match) <*> (getMessageRender <*> pure msg) - + newExamPartResult <- lift $ upsert ExamPartResult { examPartResultExamPart = examPartId , examPartResultUser = uid @@ -230,7 +230,7 @@ postECorrectR tid ssh csh examn = do return $ newResult ^? _entityVal . _examResultResult | otherwise -> return $ mOldResult ^? _Just . _entityVal . _examResultResult | otherwise -> return Nothing - + user <- userToResponse match return CorrectInterfaceResponseSuccess { cirsUser = user @@ -252,7 +252,7 @@ postECorrectR tid ssh csh examn = do { ciraMessage = mr MsgExamCorrectErrorMultipleMatchingParticipants , ciraUsers = Set.fromList users } - + let responseStatus = case response of CorrectInterfaceResponseSuccess{} -> ok200 @@ -261,5 +261,5 @@ postECorrectR tid ssh csh examn = do whenM acceptsJson $ sendResponseStatus responseStatus $ toJSON response - + redirect $ CExamR tid ssh csh examn EShowR diff --git a/src/Handler/Exam/CorrectorInvite.hs b/src/Handler/Exam/CorrectorInvite.hs index c55da69f2..871fb8d12 100644 --- a/src/Handler/Exam/CorrectorInvite.hs +++ b/src/Handler/Exam/CorrectorInvite.hs @@ -18,7 +18,7 @@ import Data.Aeson hiding (Result(..)) import qualified Data.HashSet as HashSet - + instance IsInvitableJunction ExamCorrector where type InvitationFor ExamCorrector = Exam data InvitableJunction ExamCorrector = JunctionExamCorrector diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index d5781165c..1bfa7f79a 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -96,7 +96,7 @@ examForm template html = do <*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True) <*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template) <*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template) - <*> (examOccurrenceRuleForm $ efOccurrenceRule <$> template) + <*> examOccurrenceRuleForm (efOccurrenceRule <$> template) <* aformSection MsgExamFormCorrection <*> examCorrectorsForm (efCorrectors <$> template) <* aformSection MsgExamFormParts @@ -117,7 +117,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do (addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser $ Just corrUserSuggestions) (fslI MsgExamCorrectorEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing let addRes' - | otherwise + = addRes <&> \newDat oldDat -> if | existing <- newDat `Set.intersection` Set.fromList oldDat , not $ Set.null existing @@ -201,7 +201,7 @@ examPartsForm prev = wFormToAForm $ do fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts) False $ Set.toList <$> prev where examPartForm' nudge mPrev csrf = do - (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev) + (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev) (epfNumberRes, epfNumberView) <- mpreq (isoField (from _ExamPartNumber) $ textField & cfStrip & cfCI) (fslI MsgExamPartNumber & addName (nudge "number") & addPlaceholder "1, 6a, 3.1.4, ...") (epfNumber <$> mPrev) (epfNameRes, epfNameView) <- mopt (textField & cfStrip & cfCI) (fslI MsgExamPartName & addName (nudge "name")) (epfName <$> mPrev) (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField (fslI MsgExamPartMaxPoints & addName (nudge "max-points")) (epfMaxPoints <$> mPrev) @@ -221,7 +221,7 @@ examPartsForm prev = wFormToAForm $ do (res, formWidget) <- examPartForm' nudge Nothing csrf let addRes = res <&> \newDat (Set.fromList -> oldDat) -> if - | any (\old -> fromMaybe False $ (==) <$> epfName newDat <*> epfName old) oldDat + | any (\old -> Just True == ((==) <$> epfName newDat <*> epfName old)) oldDat -> FormFailure [mr MsgExamPartAlreadyExists] | otherwise -> FormSuccess $ pure newDat return (addRes, $(widgetFile "widgets/massinput/examParts/add")) @@ -336,10 +336,10 @@ validateExam = do guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom $ NTop efDeregisterUntil >= NTop efRegisterFrom - guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments + guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments $ Just False /= ((>=) <$> efStart <*> efPublishOccurrenceAssignments) guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart - guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd - guardValidation MsgExamFinishedMustBeAfterStart . fromMaybe True $ (>=) <$> efFinished <*> efStart + guardValidation MsgExamFinishedMustBeAfterEnd $ Just False /= ((>=) <$> efFinished <*> efEnd) + guardValidation MsgExamFinishedMustBeAfterStart $ Just False /= ((>=) <$> efFinished <*> efStart) forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart) diff --git a/src/Handler/Exam/List.hs b/src/Handler/Exam/List.hs index 45c670559..e0c96add7 100644 --- a/src/Handler/Exam/List.hs +++ b/src/Handler/Exam/List.hs @@ -6,7 +6,7 @@ module Handler.Exam.List import Import import Handler.Utils - + import qualified Data.Map as Map import qualified Database.Esqueleto as E @@ -75,7 +75,7 @@ mkExamTable (Entity cid Course{..}) = do examDBTableValidator = def & defaultSorting [SortAscBy "time"] & forceFilter "may-read" (Any True) - + dbTable examDBTableValidator examDBTable diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index 5c9e2d2c3..ebc1fcde8 100644 --- a/src/Handler/Exam/New.hs +++ b/src/Handler/Exam/New.hs @@ -12,7 +12,7 @@ import Handler.Utils import Handler.Utils.Invitations import Jobs.Queue - + import qualified Data.Conduit.Combinators as C @@ -29,7 +29,7 @@ postCExamNewR tid ssh csh = do formResult newExamResult $ \ExamForm{..} -> do insertRes <- runDBJobs $ do now <- liftIO getCurrentTime - + insertRes <- insertUnique Exam { examName = efName , examCourse = cid @@ -90,7 +90,7 @@ postCExamNewR tid ssh csh = do when didRecord $ audit $ TransactionExamResultEdit examid courseParticipantUser runConduit $ selectSource [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantInactive True ] [] .| C.mapM_ recordNoShow - + return insertRes case insertRes of Nothing -> addMessageI Error $ MsgExamNameTaken efName diff --git a/src/Handler/Exam/Register.hs b/src/Handler/Exam/Register.hs index 15e2a02eb..0ed4c1385 100644 --- a/src/Handler/Exam/Register.hs +++ b/src/Handler/Exam/Register.hs @@ -21,7 +21,7 @@ data ButtonExamRegister = BtnExamRegisterOccurrence instance Universe ButtonExamRegister instance Finite ButtonExamRegister nullaryPathPiece ''ButtonExamRegister $ camelToPathPiece' 2 - + instance Button UniWorX ButtonExamRegister where btnClasses BtnExamRegisterOccurrence = [BCIsButton, BCPrimary] btnClasses BtnExamSwitchOccurrence = [BCIsButton, BCPrimary] @@ -70,7 +70,7 @@ postERegisterOccR tid ssh csh examn occn = do return (eId, occ) ((btnResult, _), _) <- runFormPost buttonForm - + formResult btnResult $ \case BtnExamDeregister -> do runDB $ do @@ -89,4 +89,4 @@ postERegisterOccR tid ssh csh examn occn = do _other -> error "Unexpected due to definition of buttonForm'" redirect $ CExamR tid ssh csh examn EShowR - + diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index 0087c26c0..05703e42a 100644 --- a/src/Handler/Exam/RegistrationInvite.hs +++ b/src/Handler/Exam/RegistrationInvite.hs @@ -16,13 +16,13 @@ import Handler.Utils.Invitations import qualified Data.Set as Set import Text.Hamlet (ihamlet) - + import Data.Aeson hiding (Result(..)) import Jobs.Queue import qualified Data.HashSet as HashSet - + instance IsInvitableJunction ExamRegistration where type InvitationFor ExamRegistration = Exam @@ -98,7 +98,7 @@ examRegistrationInvitationConfig = InvitationConfig{..} (False, True ) -> do fieldRes <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes - (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) + (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) invitationInsertHook _ (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do whenIsJust mField $ \cpField -> do void $ upsert @@ -110,7 +110,7 @@ examRegistrationInvitationConfig = InvitationConfig{..} ] queueDBJob . JobQueueNotification $ NotificationCourseRegistered examRegistrationUser examCourse audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser - + let doAudit = audit $ TransactionExamRegister eid examRegistrationUser act <* doAudit invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInvitationAccepted examName diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index c86985c46..e8b306d85 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -96,9 +96,9 @@ getEShowR tid ssh csh examn = do sumRegisteredCount = sumOf (folded . _3) occurrences - noBonus = fromMaybe False $ do + noBonus = (Just True ==) $ do guardM $ bonusOnlyPassed <$> examBonusRule - return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not + return $ Just False /= result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not sumPoints = fmap getSum . mconcat $ catMaybes [ Just $ foldMap (fmap Sum . examPartResultResult . entityVal) results @@ -187,5 +187,5 @@ getEShowR tid ssh csh examn = do examBonusW bonusRule = $(widgetFile "widgets/bonusRule") occurrenceMapping :: ExamOccurrenceName -> Maybe Widget - occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (fmap examOccurrenceMappingMapping examExamOccurrenceMapping >>= Map.lookup occName) + occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (examExamOccurrenceMapping >>= Map.lookup occName . examOccurrenceMappingMapping) $(widgetFile "exam-show") diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 1a5c67420..55545bbff 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -88,7 +88,7 @@ queryExamOccurrence = $(sqlLOJproj 6 2) queryCourseParticipant :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseParticipant)) queryCourseParticipant = $(sqlLOJproj 2 1) . $(sqlLOJproj 6 3) - + queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3) @@ -184,7 +184,7 @@ csvExamPartHeader = prism' toHeader fromHeader review _ExamPartNumber . CI.mk <$> stripPrefix partPrefix tHdr partPrefix = "part-" - + data ExamUserTableCsv = ExamUserTableCsv { csvEUserSurname :: Maybe Text @@ -498,7 +498,7 @@ postEUsersR tid ssh csh examn = do [ (epId, (examPart, mbRes)) | (Entity epId examPart, mbRes) <- rawResults ] - + dbtColonnade = mconcat $ catMaybes [ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey) , pure $ colUserNameLink (CourseR tid ssh csh . CUserR) @@ -507,7 +507,7 @@ postEUsersR tid ssh csh examn = do , pure $ colDegreeShort resultStudyDegree , pure $ colFeaturesSemester resultStudyFeatures , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence - , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> + , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> let SheetGradeSummary{achievedPasses} = examBonusAchieved uid bonus SheetGradeSummary{numSheetsPasses} = examBonusPossible uid bonus in propCell (getSum achievedPasses) (getSum numSheetsPasses) @@ -516,7 +516,7 @@ postEUsersR tid ssh csh examn = do SheetGradeSummary{sumSheetsPoints} = examBonusPossible uid bonus in propCell (getSum achievedPoints) (getSum sumSheetsPoints) , guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left - , pure $ mconcat + , pure $ mconcat [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult) | Entity epId ExamPart{..} <- sortOn (examPartNumber . entityVal) examParts ] @@ -597,7 +597,7 @@ postEUsersR tid ssh csh examn = do tell =<< optionsF [ ExamUserDeregister, ExamUserAssignOccurrence ] when (is _Just examGradingRule) $ tell =<< optionsF [ ExamUserAcceptComputedResult, ExamUserResetToComputedResult ] - when (not $ null examParts) $ + unless (null examParts) $ tell =<< optionsF [ ExamUserSetPartResult ] when doBonus $ tell =<< optionsF [ ExamUserSetBonus ] @@ -651,7 +651,7 @@ postEUsersR tid ssh csh examn = do (isPart, uid) <- lift $ guessUser' dbCsvNew if | isPart -> do - yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew + yieldM $ ExamUserCsvRegisterData uid <$> lookupOccurrence dbCsvNew newFeatures <- lift $ lookupStudyFeatures dbCsvNew Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse when (newFeatures /= oldFeatures) $ @@ -662,10 +662,10 @@ postEUsersR tid ssh csh examn = do iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes -> when (epNumber `elem` examPartNumbers) $ yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes) - + when (doBonus && is _Just (join $ csvEUserBonus dbCsvNew)) $ yield . ExamUserCsvSetBonusData False uid . join $ csvEUserBonus dbCsvNew - + whenIsJust (csvEUserExamResult dbCsvNew) $ \res -> do yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew guardResultKind res @@ -693,7 +693,7 @@ postEUsersR tid ssh csh examn = do let newResults :: Maybe (Map ExamPartNumber ExamResultPoints) newResults = sequence (csvEUserExamPartResults dbCsvNew) - <|> sequence (toMapOf (resultExamParts .> ito (over _1 $ examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld) + <|> sequence (toMapOf (resultExamParts .> ito (over _1 examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld) newBonus, oldBonus :: Maybe Points newBonus = join (csvEUserBonus dbCsvNew) @@ -702,7 +702,7 @@ postEUsersR tid ssh csh examn = do newResult, oldResult :: Maybe ExamResultPassedGrade newResult = fmap (fmap $ bool Right (Left . view passingGrade) $ is _ExamGradingGrades examGradingMode) . examGrade examVal (newBonus <|> oldBonus) =<< newResults oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') - + when doBonus $ case newBonus of _ | newBonus == oldBonus @@ -715,7 +715,7 @@ postEUsersR tid ssh csh examn = do -> yield $ ExamUserCsvSetBonusData False uid newBonus Just _ -> yield $ ExamUserCsvSetBonusData True uid newBonus - + case newResult of _ | csvEUserExamResult dbCsvNew == oldResult -> return () @@ -964,15 +964,15 @@ postEUsersR tid ssh csh examn = do | is (_ExamAttended . _Left) res -> ExamGradingPass | otherwise -> ExamGradingGrades | otherwise = return () - + registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname where Entity _ User{..} = view resultUser $ existing ! registration - + guessUser' :: ExamUserTableCsv -> DB (Bool, UserId) guessUser' ExamUserTableCsv{..} = do - let criteria = Set.fromList $ catMaybes + let criteria = Set.fromList $ catMaybes [ GuessUserMatrikelnummer <$> csvEUserMatriculation , GuessUserDisplayName <$> csvEUserName , GuessUserSurname <$> csvEUserSurname @@ -1088,7 +1088,7 @@ postEUsersR tid ssh csh examn = do audit $ TransactionExamBonusEdit eId uid | otherwise -> return () - + insert_ ExamResult { examResultExam = eId , examResultUser = uid diff --git a/src/Handler/ExamOffice/Course.hs b/src/Handler/ExamOffice/Course.hs index 2db5ecf76..6ed103c3d 100644 --- a/src/Handler/ExamOffice/Course.hs +++ b/src/Handler/ExamOffice/Course.hs @@ -28,7 +28,7 @@ getCExamOfficeR = postCExamOfficeR postCExamOfficeR tid ssh csh = do uid <- requireAuthId isModal <- hasCustomHeader HeaderIsModal - + (cid, optOuts, hasForced) <- runDB $ do cid <- getKeyBy404 (TermSchoolCourseShort tid ssh csh) optOuts <- selectList [ CourseUserExamOfficeOptOutCourse ==. cid, CourseUserExamOfficeOptOutUser ==. uid ] [] @@ -65,7 +65,7 @@ postCExamOfficeR tid ssh csh = do setTitleI MsgMenuCourseExamOffice let explanation = $(i18nWidgetFile "course-exam-office-explanation") - + [whamlet| $newline never
diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 25458c0dd..e5be277ea 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -34,7 +34,7 @@ embedRenderMessage ''UniWorX ''ButtonCloseExam id instance Button UniWorX ButtonCloseExam where btnClasses BtnCloseExam = [BCIsButton] - + examCloseWidget :: SomeRoute UniWorX -> ExamId -> Handler Widget examCloseWidget dest eId = do Exam{..} <- runDB $ get404 eId @@ -47,7 +47,7 @@ examCloseWidget dest eId = do unless (is _Nothing examClosed) $ invalidArgs ["Exam is already closed"] - + runDB $ update eId [ ExamClosed =. Just now ] addMessageI Success MsgExamDidClose redirect dest @@ -189,7 +189,7 @@ newtype ExamUserCsvExportData = ExamUserCsvExportData { csvEUserMarkSynchronised :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) - + -- | View a list of all users' grades that the current user has access to getEGradesR, postEGradesR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEGradesR = postEGradesR @@ -271,7 +271,7 @@ postEGradesR tid ssh csh examn = do E.where_ $ examResult E.^. ExamResultExam E.==. E.val eid - unless isLecturer $ + unless isLecturer $ E.where_ $ Exam.examOfficeExamResultAuth (E.val uid) examResult return (examResult, user, occurrence, studyFeatures, studyDegree, studyField, examRegistration, isSynced) @@ -314,9 +314,9 @@ postEGradesR tid ssh csh examn = do syncs' = [ Right sync | sync@(_, _, t, _) <- syncs, t > lastChange] ++ [ Left lastChange ] ++ [ Right sync | sync@(_, _, t, _) <- syncs, t <= lastChange] - + syncIcon :: Widget - syncIcon + syncIcon | not isSynced , not hasSyncs = mempty @@ -324,7 +324,7 @@ postEGradesR tid ssh csh examn = do = toWidget iconNotOK | otherwise = toWidget iconOK - + syncsModal :: Widget syncsModal = $(widgetFile "exam-office/exam-result-synced") lift $ bool id (flip modal $ Right syncsModal) hasSyncs syncIcon diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index be99b1737..c2f4f1c75 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -30,7 +30,7 @@ queryExam = to $ $(E.sqlIJproj 2 1) . $(E.sqlFOJproj 2 1) queryCourse :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Course))) queryCourse = to $ $(E.sqlIJproj 2 2) . $(E.sqlFOJproj 2 1) - + queryExternalExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExternalExam))) queryExternalExam = to $(E.sqlFOJproj 2 2) @@ -48,7 +48,7 @@ querySynchronised office = to . runReader $ do E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult E.where_ $ ExternalExam.resultIsSynced office externalExamResult return $ E.maybe (E.val 0) examSynchronised (exam' E.?. ExamId) E.+. E.maybe (E.val 0) externalExamSynchronised (externalExam' E.?. ExternalExamId) - + queryResults :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Natural)) queryResults office = to . runReader $ do exam' <- view queryExam @@ -75,7 +75,7 @@ queryIsSynced now office = to . runReader $ do E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult E.where_ . E.not_ $ ExternalExam.resultIsSynced office externalExamResult - open examClosed' = E.maybe E.true (E.>. E.val now) $ examClosed' + open examClosed' = E.maybe E.true (E.>. E.val now) examClosed' return $ E.maybe E.false examSynchronised (exam' E.?. ExamId) E.||. E.maybe E.false open (exam' E.?. ExamClosed) E.||. E.maybe E.false externalExamSynchronised (externalExam' E.?. ExternalExamId) @@ -95,7 +95,7 @@ resultResults = _dbrOutput . _3 resultIsSynced :: Getter ExamsTableData Bool resultIsSynced = to $ (>=) <$> view resultSynchronised <*> view resultResults - + -- | List of all exams where the current user may (in her function as -- exam-office) access users grades getEOExamsR :: Handler Html @@ -106,15 +106,15 @@ getEOExamsR = do examsTable <- runDB $ do let examLink :: Course -> Exam -> SomeRoute UniWorX - examLink Course{..} Exam{..} + examLink Course{..} Exam{..} = SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EGradesR courseLink :: Course -> SomeRoute UniWorX courseLink Course{..} = SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR - + externalExamLink :: ExternalExam -> SomeRoute UniWorX - externalExamLink ExternalExam{..} + externalExamLink ExternalExam{..} = SomeRoute $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEGradesR querySynchronised' = querySynchronised $ E.val uid @@ -150,11 +150,9 @@ getEOExamsR = do case (exam, course, externalExam) of (Just exam', Just course', Nothing) -> - (,,) - <$> pure (Right (exam', course')) <*> view (_4 . _Value) <*> view (_5 . _Value) + (Right (exam', course'),,) <$> view (_4 . _Value) <*> view (_5 . _Value) (Nothing, Nothing, Just externalExam') -> - (,,) - <$> pure (Left externalExam') <*> view (_4 . _Value) <*> view (_5 . _Value) + (Left externalExam',,) <$> view (_4 . _Value) <*> view (_5 . _Value) _other -> return $ error "Got exam & externalExam in same result" @@ -182,7 +180,7 @@ getEOExamsR = do & cellAttrs <>~ [ ("class", "heated") , ("style", [st|--hotness: #{tshow (heat results synced)}|]) ] - + dbtColonnade :: Colonnade Sortable _ _ dbtColonnade = mconcat @@ -192,7 +190,7 @@ getEOExamsR = do ) $ emptyOpticColonnade (resultExam . _entityVal . _examName <> resultExternalExam . _entityVal . _externalExamExamName) colExamName , emptyOpticColonnade (resultExam . _entityVal . $(multifocusG 2) _examStart _examEnd) colExamTime - , emptyOpticColonnade (resultExam . _entityVal . _examFinished) colExamFinishedOffice + , emptyOpticColonnade (resultExam . _entityVal . _examFinished) colExamFinishedOffice , emptyOpticColonnade (resultExam . _entityVal . _examClosed) colExamClosed , maybeAnchorColonnade (previews (resultCourse . _entityVal) courseLink) $ emptyOpticColonnade (resultCourse . _entityVal . _courseName <> resultExternalExam . _entityVal . _externalExamCourseName) colCourseName diff --git a/src/Handler/ExamOffice/ExternalExam.hs b/src/Handler/ExamOffice/ExternalExam.hs index 1e7bafffd..8ca0c6c8e 100644 --- a/src/Handler/ExamOffice/ExternalExam.hs +++ b/src/Handler/ExamOffice/ExternalExam.hs @@ -7,7 +7,7 @@ import Import import Handler.Utils import Handler.Utils.ExternalExam.Users - + getEEGradesR, postEEGradesR :: TermId -> SchoolId -> CourseName -> ExamName -> Handler Html getEEGradesR = postEEGradesR postEEGradesR tid ssh coursen examn = do diff --git a/src/Handler/ExamOffice/Fields.hs b/src/Handler/ExamOffice/Fields.hs index 58f7bc57a..53395acfc 100644 --- a/src/Handler/ExamOffice/Fields.hs +++ b/src/Handler/ExamOffice/Fields.hs @@ -11,7 +11,7 @@ import qualified Database.Esqueleto as E import qualified Data.Set as Set import qualified Data.Map as Map - + data ExamOfficeFieldMode = EOFNotSubscribed | EOFSubscribed @@ -78,7 +78,7 @@ postEOFieldsR = do oldFields <- runDB $ do fields <- E.select . E.from $ \examOfficeField -> do E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val uid - return $ (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced) + return (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced) return $ toMapOf (folded .> ito (over _1 E.unValue . over _2 E.unValue)) fields ((fieldsRes, fieldsView), fieldsEnc) <- runFormPost . makeExamOfficeFieldsForm uid $ Just oldFields diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs index 878e228b2..1592298db 100644 --- a/src/Handler/ExamOffice/Users.hs +++ b/src/Handler/ExamOffice/Users.hs @@ -21,7 +21,7 @@ import qualified Data.Map as Map import Data.Map ((!), (!?)) import qualified Data.HashSet as HashSet - + instance IsInvitableJunction ExamOfficeUser where type InvitationFor ExamOfficeUser = User @@ -84,11 +84,11 @@ examOfficeUserInvitationConfig = InvitationConfig{..} return $ SomeMessage MsgExamOfficeUserInvitationAccepted invitationUltDest _ _ = return $ SomeRoute NewsR - + makeExamOfficeUsersForm :: Maybe (Set (Either UserEmail UserId)) -> Form (Set (Either UserEmail UserId)) makeExamOfficeUsersForm template = renderWForm FormStandard $ do cRoute <- fromMaybe (error "makeExamOfficeUsersForm called from 404-handler") <$> getCurrentRoute - + let miAdd' :: (Text -> Text) -> FieldView UniWorX @@ -132,7 +132,7 @@ makeExamOfficeUsersForm template = renderWForm FormStandard $ do return $ map Left invitations ++ map Right knownUsers' fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired template' - + -- | Manage the list of users this user (in her function as exam-office) -- has an interest in, i.e. that authorize her to view their grades diff --git a/src/Handler/ExternalExam/Edit.hs b/src/Handler/ExternalExam/Edit.hs index 6240fd6b5..48f4d70a0 100644 --- a/src/Handler/ExternalExam/Edit.hs +++ b/src/Handler/ExternalExam/Edit.hs @@ -39,7 +39,7 @@ postEEEditR tid ssh coursen examn = do , eefOfficeSchools = schools , eefStaff = staff } - + ((examResult, examWidget'), examEnctype) <- runFormPost . externalExamForm $ Just template formResult examResult $ \ExternalExamForm{..} -> do @@ -54,7 +54,7 @@ postEEEditR tid ssh coursen examn = do } when (is _Nothing replaceRes) $ do audit $ TransactionExternalExamEdit eeId - + forM_ (eefStaff `setSymmDiff` staff) $ \change -> if | change `Set.member` eefStaff -> case change of Left invEmail -> do diff --git a/src/Handler/ExternalExam/Form.hs b/src/Handler/ExternalExam/Form.hs index 93c4273d5..9d54f3c04 100644 --- a/src/Handler/ExternalExam/Form.hs +++ b/src/Handler/ExternalExam/Form.hs @@ -5,7 +5,7 @@ module Handler.ExternalExam.Form import Import import Handler.Utils - + import Handler.ExternalExam.StaffInvite () import qualified Data.Set as Set @@ -104,7 +104,7 @@ externalExamForm template = validateForm validateExternalExam $ \html -> do validateExternalExam :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExternalExamForm m () validateExternalExam = do State.modify $ \eeForm -> eeForm & over _eefOfficeSchools (Set.delete $ eeForm ^. _eefSchool) - + ExternalExamForm{..} <- State.get isAdmin <- hasWriteAccessTo $ SchoolR eefSchool SchoolEditR diff --git a/src/Handler/ExternalExam/List.hs b/src/Handler/ExternalExam/List.hs index edd02e199..afcdf2e8f 100644 --- a/src/Handler/ExternalExam/List.hs +++ b/src/Handler/ExternalExam/List.hs @@ -3,7 +3,7 @@ module Handler.ExternalExam.List ) where import Import - + import Handler.Utils import qualified Database.Esqueleto as E @@ -24,7 +24,7 @@ getEExamListR = do queryEExam = $(E.sqlIJproj 2 1) querySchool = $(E.sqlIJproj 2 2) - + dbtSQLQuery (eexam `E.InnerJoin` school) = do E.on $ eexam E.^. ExternalExamSchool E.==. school E.^. SchoolId let diff --git a/src/Handler/ExternalExam/New.hs b/src/Handler/ExternalExam/New.hs index fb89f6418..e4f7dffac 100644 --- a/src/Handler/ExternalExam/New.hs +++ b/src/Handler/ExternalExam/New.hs @@ -32,7 +32,7 @@ postEExamNewR = do } whenIsJust insertRes $ \eeId -> do audit $ TransactionExternalExamEdit eeId - + let eefOfficeSchools' = do externalExamOfficeSchoolSchool <- Set.toList eefOfficeSchools guard $ externalExamOfficeSchoolSchool /= eefSchool @@ -41,7 +41,7 @@ postEExamNewR = do insertMany_ eefOfficeSchools' forM_ eefOfficeSchools' $ \ExternalExamOfficeSchool{..} -> audit $ TransactionExternalExamOfficeSchoolEdit eeId externalExamOfficeSchoolSchool - + let (invites, adds) = partitionEithers $ Set.toList eefStaff eefStaff' = do externalExamStaffUser <- adds @@ -50,7 +50,7 @@ postEExamNewR = do insertMany_ eefStaff' forM_ eefStaff' $ \ExternalExamStaff{..} -> audit $ TransactionExternalExamStaffEdit eeId externalExamStaffUser - + sinkInvitationsF externalExamStaffInvitationConfig $ map (, eeId, (InvDBDataExternalExamStaff, InvTokenDataExternalExamStaff)) invites forM_ invites $ \invEmail -> audit $ TransactionExternalExamStaffInviteEdit eeId invEmail diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs index 28bf3e804..4c2bd4f0b 100644 --- a/src/Handler/Help.hs +++ b/src/Handler/Help.hs @@ -10,7 +10,7 @@ import qualified Data.Map as Map import qualified Data.Yaml as Yaml import qualified Control.Monad.State.Class as State - + data HelpIdentOptions = HIUser | HIEmail | HIAnonymous deriving (Eq, Ord, Bounded, Enum, Show, Read) @@ -58,7 +58,7 @@ helpForm mReferer mUid = renderWForm FormStandard $ do Nothing -> return $ pure Nothing Just err -> let prettyErr = decodeUtf8 $ Yaml.encode err - in optionalActionW + in optionalActionW (err <$ aforced textareaField (fslI MsgHelpError) (Textarea prettyErr)) (fslI MsgHelpSendLastError) (Just True) @@ -69,7 +69,7 @@ helpForm mReferer mUid = renderWForm FormStandard $ do <*> hfSubject' <*> hfRequest' <*> hfError' - + validateHelpForm :: FormValidator HelpForm Handler () validateHelpForm = do HelpForm{..} <- State.get @@ -99,7 +99,7 @@ postHelpR = do whenIsJust hfError $ \error' -> modifySessionJson SessionError $ assertM (/= error') - + tell . pure =<< messageI Success MsgHelpSent defaultLayout $ do @@ -111,5 +111,5 @@ postHelpR = do } mFaqs <- (>>= \(mWgt, truncated) -> (, truncated) <$> mWgt) <$> traverse (faqsWidget $ Just 5) (Just <$> mReferer) - + $(widgetFile "help") diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs index acb282192..9c37026ab 100644 --- a/src/Handler/Info.hs +++ b/src/Handler/Info.hs @@ -53,7 +53,7 @@ getInfoLecturerR = $(i18nWidgetFile "info-lecturer") where allocationInfo = $(i18nWidgetFile "allocation-info") - + tooltipNew, tooltipProblem, tooltipPlanned, tooltipNewU2W :: WidgetFor UniWorX () tooltipNew = [whamlet| _{MsgLecturerInfoTooltipNew} |] tooltipProblem = [whamlet| _{MsgLecturerInfoTooltipProblem} |] @@ -64,7 +64,7 @@ getInfoLecturerR = probFeatInline = [whamlet| ^{iconTooltip tooltipProblem (Just IconProblem) True} |] -- to be used inside text blocks plannedFeat = [whamlet| ^{iconTooltip tooltipPlanned (Just IconPlanned) False} |] plannedFeatInline = [whamlet| ^{iconTooltip tooltipPlanned (Just IconPlanned) True} |] -- to be used inside text blocks - + -- new feature with given introduction date newFeat :: Integer -> Int -> Int -> WidgetFor UniWorX () newFeat year month day = do diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 817ae41f9..c0679cd31 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -21,7 +21,7 @@ data MaterialForm = MaterialForm , mfType :: Maybe (CI Text) , mfDescription :: Maybe Html , mfVisibleFrom :: Maybe UTCTime - , mfFiles :: Maybe FileUploads + , mfFiles :: Maybe FileUploads } makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm @@ -135,7 +135,7 @@ getMaterialListR tid ssh csh = do , ( "last-edit" , SortColumn (E.^. MaterialLastEdit) ) ] , dbtFilter = mconcat - [ singletonMap "may-access" . FilterProjected $ \(Any b) dbr + [ singletonMap "may-access" . FilterProjected $ \(Any b) dbr -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool ] , dbtFilterUI = mempty @@ -347,4 +347,4 @@ getMArchiveR tid ssh csh mnm = do return materialFile serveSomeFiles archiveName getMatQuery - + diff --git a/src/Handler/Metrics.hs b/src/Handler/Metrics.hs index 92bed0bc1..0250e9851 100644 --- a/src/Handler/Metrics.hs +++ b/src/Handler/Metrics.hs @@ -28,7 +28,7 @@ getMetricsR = selectRep $ do guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid encodeBearer =<< bearerToken (HashSet.singleton . Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing - + defaultLayout $ do setTitleI MsgTitleMetrics $(widgetFile "metrics") diff --git a/src/Handler/News.hs b/src/Handler/News.hs index ee46deb25..04ee47d74 100644 --- a/src/Handler/News.hs +++ b/src/Handler/News.hs @@ -29,7 +29,7 @@ getNewsR = do when (is _Nothing muid) $ notificationWidget NotificationBroad Info $(i18nWidgetFile "pitch") - + case muid of Just uid -> do newsUpcomingExams uid @@ -51,7 +51,7 @@ newsSystemMessages = do mkHideForm smId SystemMessage{..} = liftHandler $ do cID <- encrypt smId hidden <- getSystemMessageState smId <&> \UserSystemMessageState{..} -> userSystemMessageHidden > Just systemMessageLastUnhide - + (btnView, btnEnctype) <- generateFormPost . buttonForm' $ bool [BtnSystemMessageHide] [BtnSystemMessageUnhide] hidden return $ wrapForm btnView def { formSubmit = FormNoSubmit @@ -65,7 +65,7 @@ newsSystemMessages = do tell $ Any hidden return $ guardOn (not hidden || showHidden) (smId, sm, trans, hidden) - + (messages', Any anyHidden) <- liftHandler . runDB . runConduit . C.runWriterLC $ transPipe lift (selectKeys [] []) .| C.filterM (hasReadAccessTo . MessageR <=< encrypt) @@ -87,7 +87,7 @@ newsUpcomingSheets :: UserId -> Widget newsUpcomingSheets uid = do cTime <- liftIO getCurrentTime let noActiveToCutoff = toMidnight . addGregorianDurationRollOver (scaleCalendarDiffDays (-1) calendarMonth) $ utctDay cTime - + let tableData :: E.LeftOuterJoin (E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet))) (E.InnerJoin (E.SqlExpr (Maybe (Entity Submission))) (E.SqlExpr (Maybe (Entity SubmissionUser)))) @@ -104,12 +104,12 @@ newsUpcomingSheets uid = do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse - let showSheetNoActiveTo = + let showSheetNoActiveTo = E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetActiveFrom) E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetVisibleFrom) E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetHintFrom) E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetSolutionFrom) - + E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive E.&&. E.maybe showSheetNoActiveTo (E.>=. E.val cTime) (sheet E.^. SheetActiveTo) diff --git a/src/Handler/Participants.hs b/src/Handler/Participants.hs index c9af17d51..1bd09384c 100644 --- a/src/Handler/Participants.hs +++ b/src/Handler/Participants.hs @@ -35,7 +35,7 @@ instance ToNamedRecord ParticipantEntry where instance DefaultOrdered ParticipantEntry where headerOrder _ = Csv.header ["course", "email"] - + getParticipantsListR :: Handler Html getParticipantsListR = do @@ -52,10 +52,10 @@ getParticipantsListR = do schoolTerms' <- flip filterM schoolTerms'' $ \(E.Value ssh, E.Value tid) -> hasReadAccessTo $ ParticipantsR tid ssh - + let schoolTerms :: Set (SchoolId, TermId) schoolTerms = setOf (folded . $(multifocusG 2) (_1 . _Value) (_2 . _Value)) schoolTerms' - + siteLayoutMsg MsgMenuParticipantsList $ do setTitleI MsgMenuParticipantsList diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index acec907f9..e93498ecb 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -227,7 +227,7 @@ notificationForm template = wFormToAForm $ do validateSettings :: User -> FormValidator SettingsForm Handler () validateSettings User{..} = do userDisplayName' <- use _stgDisplayName - + guardValidation MsgUserDisplayNameInvalid $ validDisplayName userTitle userFirstName userSurname userDisplayName' @@ -812,7 +812,7 @@ postSetDisplayEmailR = do siteLayoutMsg MsgTitleChangeUserDisplayEmail $ do setTitleI MsgTitleChangeUserDisplayEmail $(i18nWidgetFile "set-display-email") - + getCsvOptionsR, postCsvOptionsR :: Handler Html getCsvOptionsR = postCsvOptionsR postCsvOptionsR = do diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 72de78d79..4c72381bf 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -8,14 +8,14 @@ import qualified Database.Esqueleto as E import qualified Data.Set as Set import qualified Data.CaseInsensitive as CI import qualified Data.Text as Text - + getSchoolListR :: Handler Html getSchoolListR = do let schoolLink :: SchoolId -> SomeRoute UniWorX schoolLink ssh = SomeRoute $ SchoolR ssh SchoolEditR - + dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _ dbtSQLQuery = return @@ -49,7 +49,7 @@ getSchoolListR = do psValidator = def & defaultSorting [SortAscBy "school-name"] - + table <- runDB $ dbTableWidget' psValidator DBTable{..} @@ -89,7 +89,7 @@ getSchoolEditR, postSchoolEditR :: SchoolId -> Handler Html getSchoolEditR = postSchoolEditR postSchoolEditR ssh = do sForm <- runDB $ schoolToForm ssh - + ((sfResult, sfView), sfEnctype) <- runFormPost sForm formResult sfResult $ \SchoolForm{..} -> do diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index d174152f5..1d8270e8d 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -19,7 +19,7 @@ import Handler.Sheet.Download as Handler.Sheet import Handler.Sheet.New as Handler.Sheet import Handler.Sheet.Show as Handler.Sheet - + getSIsCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html -- NOTE: The route SIsCorrR is only used to verfify corrector access rights to given sheet! getSIsCorrR _ _ _ shn = diff --git a/src/Handler/Sheet/Current.hs b/src/Handler/Sheet/Current.hs index 996199913..1646785f2 100644 --- a/src/Handler/Sheet/Current.hs +++ b/src/Handler/Sheet/Current.hs @@ -6,7 +6,7 @@ module Handler.Sheet.Current import Import import Utils.Sheet - + getSheetCurrentR :: TermId -> SchoolId -> CourseShorthand -> Handler Void getSheetCurrentR tid ssh csh = do diff --git a/src/Handler/Sheet/Download.hs b/src/Handler/Sheet/Download.hs index 0f5bfb70d..866718d3d 100644 --- a/src/Handler/Sheet/Download.hs +++ b/src/Handler/Sheet/Download.hs @@ -43,7 +43,7 @@ getSArchiveR tid ssh csh shn = do E.where_ $ sFile E.^. SheetFileSheet E.==. E.val shId E.&&. sFile E.^. SheetFileType E.==. E.val sft return . E.max_ $ sFile E.^. SheetFileModified - + serveZipArchive archiveName $ do forM_ sftDirectories $ \(sft, mTime) -> yield $ SheetFile { sheetFileType = sft diff --git a/src/Handler/Sheet/Edit.hs b/src/Handler/Sheet/Edit.hs index c7cde432e..addbde42a 100644 --- a/src/Handler/Sheet/Edit.hs +++ b/src/Handler/Sheet/Edit.hs @@ -112,11 +112,11 @@ handleSheetEdit tid ssh csh msId template dbAction = do deleteWhere [InvitationFor ==. invRef @SheetCorrector sid, InvitationEmail /<-. toListOf (folded . _1) invites] sinkInvitationsF correctorInvitationConfig invites - + return True when saveOkay $ redirect $ CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB - (FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml + (FormFailure msgs) -> forM_ msgs $ addMessage Error . toHtml _ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <- [(sfVisibleFrom =<< template, MsgSheetVisibleFrom) ,(sfActiveFrom =<< template, MsgSheetActiveFrom) diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs index 82a710a6f..0f60181c0 100644 --- a/src/Handler/Sheet/Form.hs +++ b/src/Handler/Sheet/Form.hs @@ -1,7 +1,7 @@ module Handler.Sheet.Form ( SheetForm(..), Loads , makeSheetForm - , getFtIdMap + , getFtIdMap ) where import Import @@ -44,7 +44,7 @@ data SheetForm = SheetForm -- Keine SheetId im Formular! } - + getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileReference) getFtIdMap sId = do allSheetFiles <- E.select . E.from $ \sheetFile -> do @@ -88,16 +88,16 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS <*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template) <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template) <*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template) - <*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template) + <*> correctorForm (maybe mempty sfCorrectors template) where validateSheet :: FormValidator SheetForm Handler () validateSheet = do SheetForm{..} <- State.get - guardValidation MsgSheetErrVisibility $ NTop sfVisibleFrom <= NTop sfActiveFrom - guardValidation MsgSheetErrDeadlineEarly $ NTop sfActiveFrom <= NTop sfActiveTo - guardValidation MsgSheetErrHintEarly $ NTop sfHintFrom >= NTop sfActiveFrom - guardValidation MsgSheetErrSolutionEarly $ NTop sfSolutionFrom >= NTop sfActiveTo + guardValidation MsgSheetErrVisibility $ NTop sfVisibleFrom <= NTop sfActiveFrom + guardValidation MsgSheetErrDeadlineEarly $ NTop sfActiveFrom <= NTop sfActiveTo + guardValidation MsgSheetErrHintEarly $ NTop sfHintFrom >= NTop sfActiveFrom + guardValidation MsgSheetErrSolutionEarly $ NTop sfSolutionFrom >= NTop sfActiveTo guardValidation MsgSheetErrVisibleWithoutActive $ is _Just sfActiveFrom || is _Nothing sfVisibleFrom @@ -113,7 +113,7 @@ correctorForm loads' = wFormToAForm $ do loads :: Map (Either UserEmail UserId) (CorrectorState, Load) loads = loads' <&> \(InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) -> (cState, load) - countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads + countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> Just True == byTutorial) $ Map.elems loads let @@ -124,7 +124,7 @@ correctorForm loads' = wFormToAForm $ do E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId - E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] + E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] return user miAdd :: ListPosition @@ -150,7 +150,7 @@ correctorForm loads' = wFormToAForm $ do miCell _ userIdent initRes nudge csrf = do (stateRes, stateView) <- mreq (selectField optionsFinite) (fslI MsgSheetCorrectorState & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal (byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False - (propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fslI MsgSheetCorrectorProportion & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0 + (propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative rationalField) (fslI MsgSheetCorrectorProportion & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0 let res :: FormResult (CorrectorState, Load) res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes) @@ -202,7 +202,7 @@ correctorForm loads' = wFormToAForm $ do postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Loads postProcess = Map.fromList . map postProcess' . Map.elems - where + where postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> (Either UserEmail UserId, (InvitationDBData SheetCorrector, InvitationTokenData SheetCorrector)) postProcess' = over _2 $ \(cState, load) -> (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) diff --git a/src/Handler/Sheet/List.hs b/src/Handler/Sheet/List.hs index 7421017df..e616e81ab 100644 --- a/src/Handler/Sheet/List.hs +++ b/src/Handler/Sheet/List.hs @@ -76,7 +76,7 @@ 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 diff --git a/src/Handler/StorageKey.hs b/src/Handler/StorageKey.hs index 2bb5cf233..fc9de6e62 100644 --- a/src/Handler/StorageKey.hs +++ b/src/Handler/StorageKey.hs @@ -11,6 +11,8 @@ import qualified Data.ByteString.Base64 as Base64 (encode, decodeLenient) import qualified Data.Binary as Binary (encode) import qualified Crypto.KDF.HKDF as HKDF +{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} + data StorageKeyType = SKTExamCorrect @@ -64,7 +66,7 @@ postStorageKeyR = do timestamp = if | Just ts <- skReqTimestamp, timestampInBounds -> ts | otherwise -> now - + salt <- let sltSize = hashDigestSize SHA3_256 in if | Just slt <- Base64.decodeLenient . encodeUtf8 <$> skReqSalt , timestampInBounds diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index f81ecef61..aae806f26 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -32,7 +32,7 @@ import Handler.Utils import qualified Database.Esqueleto as E - + getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSubmissionOwnR tid ssh csh shn = do authId <- requireAuthId diff --git a/src/Handler/Submission/Assign.hs b/src/Handler/Submission/Assign.hs index 53aec90d0..929df786e 100644 --- a/src/Handler/Submission/Assign.hs +++ b/src/Handler/Submission/Assign.hs @@ -3,7 +3,7 @@ module Handler.Submission.Assign , getCAssignR, postCAssignR , getSAssignR, postSAssignR ) where - + import Import hiding (link, unzip) import Handler.Utils hiding (colSchool) @@ -74,7 +74,7 @@ postSAssignR tid ssh csh shn = do assignHandler :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html assignHandler tid ssh csh cid assignSids = do currentRoute <- fromMaybe (error "assignHandler called from 404-handler") <$> liftHandler getCurrentRoute - + -- gather data (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment, ((btnViews, btnCsrf), btnEncoding)) <- runDB $ do -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh @@ -97,7 +97,7 @@ assignHandler tid ssh csh cid assignSids = do assignSheetNames' = sheetName <$> mapMaybe (`Map.lookup` sheets) assignSids' assignButtons = Map.fromSet (maybe BtnSubmissionsAssignAll BtnSubmissionsAssign) $ Set.fromList . bool (Nothing :) id (null sheetList) $ map Just assignSheetNames' - + ((btnResult, btnViews'), btnEncoding) <- runFormPost . identifyForm FIDAssignSubmissions $ \csrf -> fmap (over _1 (asum . fmap (hoistMaybe =<<)) . over _2 (, csrf) . unzip) . for assignButtons $ \btn -> mopt (buttonField btn) "" Nothing @@ -132,7 +132,7 @@ assignHandler tid ssh csh cid assignSids = do | otherwise -> do addMessageI Error $ MsgSheetsUnassignable $ CI.original shn return Nothing - if | null sub_ok && null sub_fail -> + if | null sub_ok && null sub_fail -> return $ Map.insert shn (status, countMapElems plan, deficit) acc | otherwise -> do (plan', deficit') <- lift $ handle ignoreExceptions $ planSubmissions sid Nothing @@ -280,7 +280,7 @@ assignHandler tid ssh csh cid assignSids = do doWrap $(widgetFile "corrections-overview") - + data ButtonSubmissionsAssign = BtnSubmissionsAssign SheetName | BtnSubmissionsAssignAll diff --git a/src/Handler/Submission/Correction.hs b/src/Handler/Submission/Correction.hs index 1130e9a0e..0de27b056 100644 --- a/src/Handler/Submission/Correction.hs +++ b/src/Handler/Submission/Correction.hs @@ -51,7 +51,7 @@ postCorrectionR tid ssh csh shn cid = do MsgRenderer mr <- getMsgRenderer case results of [(Entity cId Course{..}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector, E.Value filesCorrected)] -> do - let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) + let ratingComment = submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) . Text.strip pointsForm = case sheetType of NotGraded -> pure Nothing @@ -67,7 +67,7 @@ postCorrectionR tid ssh csh shn cid = do | not isLecturer = wFormToAForm $ pure . Just <$> requireAuthId | otherwise = wFormToAForm $ do let correctors = E.from $ \user -> do - let isCorrector = E.exists . E.from $ \sheetCorrector -> + let isCorrector = E.exists . E.from $ \sheetCorrector -> E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. E.val shId isLecturer' = E.exists . E.from $ \lecturer -> @@ -151,7 +151,7 @@ postCorrectionR tid ssh csh shn cid = do getCorrectionUserR tid ssh csh shn cid = do - + sub <- decrypt cid results <- runDB $ correctionData tid ssh csh shn sub diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index 286481651..59cca93b8 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -104,9 +104,9 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident submittorsForm' = maybeT submittorsForm $ do restr <- MaybeT (maybeCurrentBearerRestrictions @Value) >>= hoistMaybe . preview (_Object . ix "submittors" . _Array) let _Submittor = prism (either toJSON toJSON) $ \x -> first (const x) $ JSON.parseEither (\x' -> fmap Right (parseJSON x') <|> fmap Left (parseJSON x')) x - submittors <- fmap (pure @FormResult @([Either UserEmail CryptoUUIDUser])) . forM (toList restr) $ hoistMaybe . preview _Submittor + submittors <- fmap (pure @FormResult @[Either UserEmail CryptoUUIDUser]) . forM (toList restr) $ hoistMaybe . preview _Submittor fmap Set.fromList <$> forMOf (traverse . traverse . _Right) submittors decrypt - + submittorsForm | isLecturer = do -- Form is being used by lecturer; allow Everything™ @@ -165,7 +165,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident guard $ Map.size dat > 1 -- User may drop from submission only if it already exists; no directly creating submissions for other people - guard $ maybe True (/= Right uid) (dat !? delPos) || isJust msmid + guard $ Just (Right uid) /= dat !? delPos || isJust msmid miDeleteList dat delPos @@ -304,7 +304,7 @@ submissionHelper tid ssh csh shn mcid = do return (userName, submissionEdit E.^. SubmissionEditTime) forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time - corrector <- fmap join $ traverse getEntity submissionRatingBy + corrector <- join <$> traverse getEntity submissionRatingBy return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector) @@ -336,9 +336,9 @@ submissionHelper tid ssh csh shn mcid = do when ( is _Nothing muid && is _Nothing msubmission && not isLecturer - ) + ) notAuthenticated - + -- Determine old submission users subUsersOld <- if | Just smid <- msmid -> Set.union @@ -411,7 +411,7 @@ submissionHelper tid ssh csh shn mcid = do } audit $ TransactionSubmissionEdit sid shid return sid - + -- Determine new submission users subUsers <- if | isLecturer -> return adhocMembers @@ -461,7 +461,7 @@ submissionHelper tid ssh csh shn mcid = do audit $ TransactionSubmissionUserDelete smid subUid unless (Just subUid == muid) $ queueDBJob . JobQueueNotification $ NotificationSubmissionUserDeleted subUid shid smid - + addMessageI Success $ if | Nothing <- msmid -> MsgSubmissionCreated | otherwise -> MsgSubmissionUpdated return smid @@ -558,7 +558,7 @@ submissionHelper tid ssh csh shn mcid = do courseSchool = ssh courseShorthand = csh in $(widgetFile "correction-user") - + defaultLayout $ do setTitleI $ MsgSubmissionEditHead tid ssh csh shn diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index 12544e87d..27dff4edb 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -193,7 +193,7 @@ colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult ( colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _, _, _) } mkUnique -> case sheetType of - NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty) + NotGraded -> pure $ over (_1.mapped) (_2 .~) (FormSuccess Nothing, mempty) _other -> over (_1.mapped) (_2 .~) . over _2 fvWidget <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints) ) @@ -201,7 +201,7 @@ colMaxPointsField :: _ => Colonnade Sortable CorrectionTableData (DBCell m (Form colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _, _, _) } -> sheetType) colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) -colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (cellAttrs <>~ [("style","width:60%")]) $ formCell id +colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) @@ -398,11 +398,11 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams , FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) -> let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7 criteria' = map CI.mk . unpack <$> Set.toList criteria - in any (\c -> c `isInfixOf` cid) criteria' + in any (`isInfixOf` cid) criteria' ) ] , dbtFilterUI = fromMaybe mempty dbtFilterUI - , dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI } + , dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI } , dbtParams , dbtIdent = "corrections" :: Text , dbtCsvEncode = noCsvEncode @@ -465,8 +465,8 @@ correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do -- let statistics = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary -- return (tableRes, statistics) - let actionRes = actionRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False) - & mapped._1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast + let actionRes = actionRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False) + <&> _1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast auditAllSubEdit = mapM_ $ \sId -> getJust sId >>= \sub -> audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet formResult actionRes $ \case @@ -610,7 +610,7 @@ assignAction selId = ( CorrSetCorrector E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId - E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] + E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] E.distinct $ return user diff --git a/src/Handler/Submission/SubmissionUserInvite.hs b/src/Handler/Submission/SubmissionUserInvite.hs index 1b8491d57..1fd36903e 100644 --- a/src/Handler/Submission/SubmissionUserInvite.hs +++ b/src/Handler/Submission/SubmissionUserInvite.hs @@ -15,7 +15,7 @@ import Text.Hamlet (ihamlet) import qualified Data.HashSet as HashSet - + instance IsInvitableJunction SubmissionUser where type InvitationFor SubmissionUser = Submission data InvitableJunction SubmissionUser = JunctionSubmissionUser diff --git a/src/Handler/Submission/Upload.hs b/src/Handler/Submission/Upload.hs index 026677686..9e66ef7b4 100644 --- a/src/Handler/Submission/Upload.hs +++ b/src/Handler/Submission/Upload.hs @@ -31,7 +31,7 @@ explainSubmissionDoneMode SubmissionDoneNever = return $(i18nWidgetFile "submis explainSubmissionDoneMode SubmissionDoneAlways = return $(i18nWidgetFile "submission-done-tip/always") explainSubmissionDoneMode SubmissionDoneByFile = return $(i18nWidgetFile "submission-done-tip/by-file") - + getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html getCorrectionsUploadR = postCorrectionsUploadR postCorrectionsUploadR = do diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 1eb650483..79ee42ae6 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -57,9 +57,8 @@ postMessageR cID = do runFormPost . identifyForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard $ (,) <$> fmap (Entity tId) - ( SystemMessageTranslation - <$> pure systemMessageTranslationMessage - <*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage) + ( SystemMessageTranslation systemMessageTranslationMessage + <$> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage) <*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageTranslationContent) <*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageTranslationSummary) ) @@ -71,9 +70,8 @@ postMessageR cID = do & filter (\l -> none (`langMatches` l) $ Map.keys ts') ((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard - $ SystemMessageTranslation - <$> pure smId - <*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang) + $ SystemMessageTranslation smId + <$> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang) <*> areq htmlField (fslI MsgSystemMessageContent) Nothing <*> aopt htmlField (fslI MsgSystemMessageSummary) Nothing diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 94ae7ee53..329dcf839 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -40,13 +40,13 @@ guessDay tid@TermIdentifier{ year, season = Winter } TermDayLectureStart guessDay tid@TermIdentifier{ year, season = Winter } TermDayLectureEnd = fromWeekDate (succ year) ((wWeekStart + 21) `div` bool 53 54 longYear) 5 where longYear = is _Just $ fromWeekDateValid year 53 1 - (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart + (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart guessDay tid@TermIdentifier{ year, season = Summer } TermDayLectureStart = fromWeekDate year (wWeekStart + 2) 1 - where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart + where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart guessDay tid@TermIdentifier{ year, season = Summer } TermDayLectureEnd = fromWeekDate year (wWeekStart + 17) 5 - where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart + where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX) diff --git a/src/Handler/Tutorial/Edit.hs b/src/Handler/Tutorial/Edit.hs index be1b1d36d..d15dc1c76 100644 --- a/src/Handler/Tutorial/Edit.hs +++ b/src/Handler/Tutorial/Edit.hs @@ -68,7 +68,7 @@ postTEditR tid ssh csh tutn = do } when (is _Nothing insertRes) $ do audit $ TransactionTutorialEdit tutid - + let (invites, adds) = partitionEithers $ Set.toList tfTutors deleteWhere [ TutorTutorial ==. tutid ] diff --git a/src/Handler/Tutorial/Form.hs b/src/Handler/Tutorial/Form.hs index bba53a709..4b7aed8a2 100644 --- a/src/Handler/Tutorial/Form.hs +++ b/src/Handler/Tutorial/Form.hs @@ -43,7 +43,7 @@ tutorialForm cid template html = do (addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser . Just $ tutUserSuggestions uid) (fslI MsgTutorEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing let addRes' - | otherwise + = addRes <&> \newDat oldDat -> if | existing <- newDat `Set.intersection` Set.fromList oldDat , not $ Set.null existing diff --git a/src/Handler/Tutorial/New.hs b/src/Handler/Tutorial/New.hs index 0e6e65cfc..da9ca7f16 100644 --- a/src/Handler/Tutorial/New.hs +++ b/src/Handler/Tutorial/New.hs @@ -39,7 +39,7 @@ postCTutorialNewR tid ssh csh = do } whenIsJust insertRes $ \tutid -> do audit $ TransactionTutorialEdit tutid - + let (invites, adds) = partitionEithers $ Set.toList tfTutors insertMany_ $ map (Tutor tutid) adds sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 15de58bf3..88d0340fd 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -57,7 +57,7 @@ instance Finite UserAction nullaryPathPiece ''UserAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''UserAction id - + data AllUsersAction = AllUsersLdapSync deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) @@ -74,7 +74,7 @@ getUsersR = postUsersR postUsersR = do MsgRenderer mr <- getMsgRenderer let - dbtColonnade = mconcat $ + dbtColonnade = mconcat [ dbSelect (applying _2) id (return . view (_dbrOutput . _entityKey)) , sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM (AdminUserR <$> encrypt uid) @@ -136,7 +136,7 @@ postUsersR = do (First (Just act), usrMap) <- inp let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap return (act, usrSet) - + over _1 postprocess <$> dbTable psValidator DBTable { dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User)) , dbtRowKey = (E.^. UserId) @@ -233,7 +233,7 @@ postUsersR = do formResult allUsersRes $ \case AllUsersLdapSync -> do runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) - addMessageI Success $ MsgSynchroniseLdapAllUsersQueued + addMessageI Success MsgSynchroniseLdapAllUsersQueued redirect UsersR let allUsersWgt' = wrapForm allUsersWgt def { formSubmit = FormNoSubmit @@ -329,10 +329,10 @@ postAdminUserR uuid = do | otherwise -> addMessageI Info MsgAccessRightsNotChanged redirect $ AdminUserR uuid - + userAuthenticationAction = \case BtnAuthLDAP -> do - let + let campusHandler :: MonadPlus m => Auth.CampusUserException -> m a campusHandler _ = mzero campusResult <- runMaybeT . handle campusHandler $ do @@ -347,7 +347,7 @@ postAdminUserR uuid = do runDBJobs $ do update uid [ UserAuthentication =. AuthLDAP ] queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid userAuthentication - + addMessageI Success MsgAuthLDAPConfigured redirect $ AdminUserR uuid BtnAuthPWHash -> do @@ -569,7 +569,7 @@ functionInvitationConfig = InvitationConfig{..} itStartsAt = Nothing return InvitationTokenConfig{..} invitationRestriction _ _ = return Authorized - invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure $ (JunctionUserFunction invTokenUserFunctionFunction, ()) + invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure (JunctionUserFunction invTokenUserFunctionFunction, ()) invitationInsertHook _ _ _ _ _ = id invitationSuccessMsg (Entity _ School{..}) (Entity _ UserFunction{..}) = do MsgRenderer mr <- getMsgRenderer @@ -583,8 +583,8 @@ functionInvitationConfig = InvitationConfig{..} return . SomeRoute $ case currentTerm of [E.Value tid] -> TermSchoolCourseListR tid ssh _other -> CourseListR - - + + getAdminNewFunctionaryInviteR, postAdminNewFunctionaryInviteR :: Handler Html getAdminNewFunctionaryInviteR = postAdminNewFunctionaryInviteR postAdminNewFunctionaryInviteR = do @@ -593,7 +593,7 @@ postAdminNewFunctionaryInviteR = do E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val uid E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin return $ userAdmin E.^. UserFunctionSchool - + ((invitesResult, invitesWgt), invitesEncoding) <- runFormPost . renderWForm FormStandard $ do now <- liftIO getCurrentTime let @@ -619,9 +619,9 @@ postAdminNewFunctionaryInviteR = do sinkInvitationsF functionInvitationConfig [ (mail, schoolId, (InvDBDataUserFunction deadline, InvTokenDataUserFunction (unSchoolKey schoolId) function)) | mail <- emails ] - unless (null emails) $ + unless (null emails) $ tell . pure <=< messageI Success . MsgFunctionariesInvited $ length emails - unless (null uids) $ + unless (null uids) $ tell . pure <=< messageI Success . MsgFunctionariesAdded $ length uids siteLayoutMsg MsgFunctionaryInviteHeading $ do diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index 07858b9f1..bcdd889ce 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -100,7 +100,7 @@ postAdminUserAddR = do when (aufAuth == AuthKindPWHash) $ lift . queueDBJob $ JobSendPasswordReset uid return uid - + case didInsert of Just uid -> do addMessageI Success MsgUserAdded diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index de308ce3d..b8a9f9375 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -27,7 +27,7 @@ import Handler.Utils.Database as Handler.Utils import Handler.Utils.Occurrences as Handler.Utils import Handler.Utils.Memcached as Handler.Utils import Handler.Utils.Files as Handler.Utils - + import Handler.Utils.Term as Handler.Utils import Control.Monad.Logger @@ -58,7 +58,7 @@ serveOneFile source = do serveSomeFiles :: forall file. HasFileReference file => FilePath -> ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent serveSomeFiles archiveName source = serveSomeFiles' archiveName $ source .| C.map Left -serveSomeFiles' :: forall file. HasFileReference file => FilePath -> ConduitT () (Either file File) (YesodDB UniWorX) () -> Handler TypedContent +serveSomeFiles' :: forall file. HasFileReference file => FilePath -> ConduitT () (Either file File) (YesodDB UniWorX) () -> Handler TypedContent serveSomeFiles' archiveName source = do results <- runDB . runConduit $ source .| peekN 2 diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs index 27e3c3d81..be5ef5a57 100644 --- a/src/Handler/Utils/Allocation.hs +++ b/src/Handler/Utils/Allocation.hs @@ -19,7 +19,7 @@ import qualified Database.Esqueleto.Utils as E import Control.Monad.Trans.State (execStateT) import qualified Control.Monad.State.Class as State (get, modify') -import Data.List (genericLength, elemIndex) +import Data.List (genericLength) import qualified Data.Vector as Vector import Data.Vector.Lens (vector) import qualified Data.Set as Set @@ -36,7 +36,7 @@ import qualified Data.Conduit.List as C import Data.Generics.Product.Param import qualified Crypto.Hash as Crypto - + import Language.Haskell.TH (nameBase) @@ -50,7 +50,7 @@ data MatchingExcludedReason nullaryPathPiece ''MatchingExcludedReason $ camelToPathPiece' 2 pathPieceJSON ''MatchingExcludedReason - + data MatchingLogRun = MatchingLogRun { matchingLogRunCourseRestriction :: Maybe (Set CourseId) , matchingLogRunCoursesExcluded :: Set CourseId @@ -73,7 +73,7 @@ allocationStarted allocId = fmap (E.unValue <=< listToMaybe) . E.select . E.from ordinalPriorities :: Monad m => ConduitT UserMatriculation (Map UserMatriculation AllocationPriority) m () ordinalPriorities = evalStateC 0 . C.mapM $ \matr -> singletonMap matr <$> (AllocationPriorityOrdinal <$> State.get <* State.modify' succ) - + sinkAllocationPriorities :: AllocationId -> ConduitT (Map UserMatriculation AllocationPriority) Void DB Int64 sinkAllocationPriorities allocId = fmap getSum . C.foldMapM . ifoldMapM $ \matr prio -> @@ -84,12 +84,12 @@ sinkAllocationPriorities allocId = fmap getSum . C.foldMapM . ifoldMapM $ \matr E.where_ $ user E.^. UserId E.==. allocationUser E.^. AllocationUserUser E.&&. user E.^. UserMatrikelnummer E.==. E.val (Just matr) - + computeAllocation :: Entity Allocation -> Maybe (Set CourseId) -- ^ Optionally restrict allocation to only consider the given courses -> DB ( AllocationFingerprint , Set (UserId, CourseId) - , Seq MatchingLogRun + , Seq MatchingLogRun ) computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = do allocations <- selectList [ CourseParticipantAllocated ==. Just allocId, CourseParticipantState ==. CourseParticipantActive ] [] @@ -106,7 +106,7 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d let deregistrations' = deregistrations & map ((, Sum 1) . E.unValue) & Map.fromListWith (<>) - + users' <- selectList [ AllocationUserAllocation ==. allocId ] [] let users'' = users' & mapMaybe ( runMaybeT $ do @@ -149,7 +149,7 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d let tellExcluded :: MatchingExcludedReason -> StateT _ _ () tellExcluded reason = State.modify' $ Map.insertWith (<>) (courseApplicationUser, courseApplicationCourse) (opoint reason :: NonNull (Set MatchingExcludedReason)) - + when (courseApplicationRatingVeto || maybe False not (courseApplicationRatingPoints ^? _Just . passingGrade . _Wrapped)) $ tellExcluded MatchingExcludedVeto @@ -184,7 +184,7 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d _other -> mempty gradeOrdinalPlaces :: Natural gradeOrdinalPlaces = round . abs $ ordinalUsers * gradeOrdinalProportion - + let centralNudge user cloneIndex grade = case allocationPrio user of AllocationPriorityNumeric{..} -> let allocationPriorities' = under vector (sortOn Down) allocationPriorities @@ -193,7 +193,7 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d in AllocationPriorityComparisonNumeric . withNumericGrade . fromInteger . fromMaybe minPrio $ allocationPriorities Vector.!? fromIntegral cloneIndex AllocationPriorityOrdinal{..} | gradeOrdinalPlaces > 0 - -> let allocationOrdinal' = gradeScale / fromIntegral gradeOrdinalPlaces * fromIntegral allocationOrdinal + -> let allocationOrdinal' = gradeScale / fromIntegral gradeOrdinalPlaces * fromIntegral allocationOrdinal in AllocationPriorityComparisonOrdinal (Down cloneIndex) $ withNumericGrade allocationOrdinal' AllocationPriorityOrdinal{..} -> AllocationPriorityComparisonOrdinal (Down cloneIndex) $ fromIntegral allocationOrdinal @@ -201,7 +201,7 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d withNumericGrade :: Rational -> Rational withNumericGrade | Just grade' <- grade - = let numberGrade' = fromMaybe (error "non-passing grade") (fromIntegral <$> elemIndex grade' passingGrades) / pred (genericLength passingGrades) + = let numberGrade' = maybe (error "non-passing grade") fromIntegral (elemIndex grade' passingGrades) / pred (genericLength passingGrades) passingGrades = sort $ filter (view $ passingGrade . _Wrapped) universeF numericGrade = -gradeScale + numberGrade' * 2 * gradeScale in (+) numericGrade @@ -210,10 +210,10 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d let inputs = Binary.encode (users'', capacities, preferences, gradeScale, gradeOrdinalPlaces) - + fingerprint :: AllocationFingerprint fingerprint = Crypto.hashlazy inputs - + g = onCryptoFailure (\_ -> error "Could not create DRG") id . fmap drgNewSeed . seedFromBinary $ kmaclazy @(SHAKE256 320) (encodeUtf8 . (pack :: String -> Text) $ nameBase 'computeAllocation) allocationMatchingSeed inputs let @@ -244,7 +244,7 @@ doAllocation :: AllocationId -> DB () doAllocation allocId now regs = forM_ regs $ \(uid, cid) -> do - mField <- (courseApplicationField . entityVal =<<) . listToMaybe <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] [] + mField <- (courseApplicationField . entityVal <=< listToMaybe) <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] [] void $ upsert (CourseParticipant cid uid now mField (Just allocId) CourseParticipantActive) [ CourseParticipantRegistration =. now diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 0743d8902..153ba69ea 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -3,7 +3,7 @@ module Handler.Utils.Communication , CommunicationRoute(..) , Communication(..) , commR - , crJobsCourseCommunication, crTestJobsCourseCommunication + , crJobsCourseCommunication, crTestJobsCourseCommunication -- * Re-Exports , Job(..) ) where diff --git a/src/Handler/Utils/Course.hs b/src/Handler/Utils/Course.hs index a595c37ca..c3f39056e 100644 --- a/src/Handler/Utils/Course.hs +++ b/src/Handler/Utils/Course.hs @@ -6,7 +6,7 @@ import Handler.Utils.Delete import qualified Database.Esqueleto as E import qualified Data.Set as Set - + courseDeleteRoute :: Set CourseId -> DeleteRoute Course courseDeleteRoute drRecords = DeleteRoute @@ -20,7 +20,7 @@ courseDeleteRoute drRecords = DeleteRoute return [whamlet| #{cName} (_{ShortTermIdentifier (unTermKey tid')}, #{sName}) |] - , drRecordConfirmString = \(E.Value cName, E.Value ssh', _, E.Value tid') -> + , drRecordConfirmString = \(E.Value cName, E.Value ssh', _, E.Value tid') -> return [st|#{termToText (unTermKey tid')}/#{ssh'}/#{cName}|] , drCaption = SomeMessage MsgCourseDeleteQuestion , drSuccessMessage = SomeMessage MsgCourseDeleted diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 128b94b3b..2a38b6b7f 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -55,7 +55,7 @@ decodeCsv' fromCsv' = do encOpts <- maybe def (userCsvOptions . entityVal) <$> lift maybeAuth let - recode' + recode' | enc == "UTF8" = id | otherwise @@ -132,7 +132,7 @@ decodeCsv' fromCsv' = do newline = 10 cr = 13 - + encodeCsv :: ( ToNamedRecord csv , MonadHandler m @@ -151,7 +151,7 @@ encodeCsv hdr = do | otherwise = encodeLazyByteString enc . decodeLazyByteString UTF8 where enc = csvOpts ^. _csvFormat . _csvEncoding - fmap (encodeByNameWith (csvOpts ^. _csvFormat . _CsvEncodeOptions) hdr) (C.foldMap pure) >>= C.sourceLazy . recode' + C.foldMap pure >>= (C.sourceLazy . recode') . encodeByNameWith (csvOpts ^. _csvFormat . _CsvEncodeOptions) hdr timestampCsv :: ( MonadHandler m , HandlerSite m ~ UniWorX @@ -181,7 +181,7 @@ encodeDefaultOrderedCsv :: forall csv m. => ConduitT csv ByteString m () encodeDefaultOrderedCsv = encodeCsv $ headerOrder (error "headerOrder" :: csv) - + respondCsv :: ToNamedRecord csv => Header -> ConduitT () csv Handler () diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index c800b8857..7fd3c4c54 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -175,7 +175,7 @@ validDateTimeFormats TimeLocale{..} SelFormatTime = Set.fromList . concat . catM ] , do guard $ uncurry (/=) amPm - guard $ any (any $ not . Char.isLower) [fst amPm, snd amPm] + guard . not $ all (all Char.isLower) [fst amPm, snd amPm] Just [ DateTimeFormat "%I:%M %P" , DateTimeFormat "%I:%M:%S %P" @@ -310,7 +310,7 @@ instance Csv.FromField ZonedTime where utcRes = localTimeToUTC localRes LTUUnique{_ltuResult} <- pure utcRes return $ utcToZonedTime _ltuResult - + parseFormats = do date <- ["%Y-%m-%d", "%d.%m.%Y"] sep <- ["T", " "] diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs index 4fc926ffa..56cf00420 100644 --- a/src/Handler/Utils/Delete.hs +++ b/src/Handler/Utils/Delete.hs @@ -111,7 +111,7 @@ deleteR' DeleteRoute{..} = do redirect drSuccess False -> redirect drAbort - + targetRoute <- fromMaybe (error "getDeleteR called from 404-handler") <$> getCurrentRoute let deleteForm = wrapForm' BtnDelete deleteFormWdgt def { formAction = Just $ SomeRoute targetRoute diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index e54f9c3f4..e192dc688 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -96,7 +96,7 @@ examBonus (Entity eId Exam{..}) = runConduit $ E.on $ examRegistration E.^. ExamRegistrationOccurrence E.==. examOccurrence E.?. ExamOccurrenceId E.where_ $ sheet E.^. SheetCourse E.==. E.val examCourse E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val eId - E.where_ $ E.case_ + E.where_ $ E.case_ [ E.when_ ( E.not_ . E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence ) E.then_ @@ -137,8 +137,8 @@ getRelevantSheetsUpTo cid uid mCutoff postprocess = Map.fromList . map postprocess' where postprocess' (E.Value sId, E.Value sType, fmap entityVal -> sub) = (sId, ) . (sType, ) $ assertM submissionRatingDone sub >>= submissionRatingPoints - - + + examResultBonus :: ExamBonusRule @@ -158,7 +158,7 @@ examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of where achieved = toRational (getSum $ achievedPoints bonusAchieved) + scalePasses (getSum $ achievedPasses bonusAchieved) possible = toRational (getSum $ sumSheetsPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible) - + scalePasses :: Integer -> Rational -- ^ Rescale passes so count of all sheets with pass is worth as many points as sum of all sheets with points scalePasses passes @@ -179,7 +179,7 @@ examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of -> succ whole | otherwise -> pred whole - + examGrade :: ( MonoFoldable mono , Element mono ~ ExamResultPoints ) @@ -204,7 +204,7 @@ examGrade Exam{..} mBonus (otoList -> results) -> ps | otherwise = ps - + pointsToGrade :: Points -> Maybe ExamGrade pointsToGrade ps = examGradingRule <&> \case ExamGradingKey{..} @@ -234,9 +234,9 @@ examBonusGrade exam@Exam{..} bonusInp = (mBonus, ) . examGrade exam mBonus bonusPossible = normalSummary <$> sheetSummary bonusAchieved = (<>) <$> fmap normalSummary sheetSummary <*> fmap bonusSummary sheetSummary - - + + data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig { eaocMinimizeRooms :: Bool , eaocFinenessCost :: Rational -- ^ Cost factor incentivising shorter common prefixes on breaks between rooms @@ -257,7 +257,7 @@ makeLenses_ ''ExamAutoOccurrenceConfig deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } ''ExamAutoOccurrenceConfig - + examAutoOccurrence :: forall seed. Hashable seed @@ -290,7 +290,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences nullResult = (Nothing, view _2 <$> users) usersCount :: forall a. Num a => a usersCount = getSum $ foldMap (Sum . fromIntegral . Set.size) users' - + users' :: Map [CI Char] (Set UserId) -- ^ Finest partition of users users' = case rule of @@ -367,7 +367,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences wordMap = Map.fromListWith (+) wordLengths wordIx :: Iso' wordId Int - wordIx = iso (\wId -> let Just ix' = findIndex (== wId) $ Array.elems collapsedWords + wordIx = iso (\wId -> let Just ix' = elemIndex wId $ Array.elems collapsedWords in ix' ) (collapsedWords Array.!) @@ -448,7 +448,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences | otherwise -> return (accCost', accMap') lineIxs = reverse $ map (view _1) lineLengths in accumResult 0 (Map.size wordMap) (0, []) - + widthCost :: Maybe lineId -> Natural -> Natural -> Extended Rational widthCost l lineWidth w @@ -463,7 +463,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences where longestLine = maximum . mapNonNull (view _2) $ impureNonNull occurrences' - + lcp :: Eq a => [a] -> [a] -> [a] -- ^ Longest common prefix lcp [] _ = [] @@ -588,7 +588,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences occSize :: Num a => ExamOccurrenceId -> a occSize occId = fromIntegral . length $ Map.filter (== Just occId) resultUsers - + rangeAlphabet :: Set (CI Char) rangeAlphabet | ExamRoomSurname <- rule diff --git a/src/Handler/Utils/ExamOffice/Exam.hs b/src/Handler/Utils/ExamOffice/Exam.hs index 30f1d30c9..2a21e24c7 100644 --- a/src/Handler/Utils/ExamOffice/Exam.hs +++ b/src/Handler/Utils/ExamOffice/Exam.hs @@ -15,7 +15,7 @@ resultIsSynced authId examResult = (hasSchool E.&&. allSchools) E.||. (E.not_ ha anySync = E.exists . E.from $ \synced -> E.where_ $ synced E.^. ExamOfficeResultSyncedResult E.==. examResult E.^. ExamResultId E.&&. synced E.^. ExamOfficeResultSyncedTime E.>=. examResult E.^. ExamResultLastChanged - + hasSchool = E.exists . E.from $ \userFunction -> E.where_ $ userFunction E.^. UserFunctionUser E.==. authId E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice @@ -27,7 +27,7 @@ resultIsSynced authId examResult = (hasSchool E.&&. allSchools) E.||. (E.not_ ha E.&&. synced E.^. ExamOfficeResultSyncedResult E.==. examResult E.^. ExamResultId E.&&. synced E.^. ExamOfficeResultSyncedTime E.>=. examResult E.^. ExamResultLastChanged - + examOfficeExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office -> E.SqlExpr (Entity ExamResult) -> E.SqlExpr (E.Value Bool) diff --git a/src/Handler/Utils/ExamOffice/ExternalExam.hs b/src/Handler/Utils/ExamOffice/ExternalExam.hs index 76a24139c..9dcac4d84 100644 --- a/src/Handler/Utils/ExamOffice/ExternalExam.hs +++ b/src/Handler/Utils/ExamOffice/ExternalExam.hs @@ -16,7 +16,7 @@ resultIsSynced authId eexamResult = (hasSchool E.&&. allSchools) E.||. (E.not_ h anySync = E.exists . E.from $ \synced -> E.where_ $ synced E.^. ExamOfficeExternalResultSyncedResult E.==. eexamResult E.^. ExternalExamResultId E.&&. synced E.^. ExamOfficeExternalResultSyncedTime E.>=. eexamResult E.^. ExternalExamResultLastChanged - + hasSchool = E.exists . E.from $ \userFunction -> E.where_ $ userFunction E.^. UserFunctionUser E.==. authId E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice @@ -28,7 +28,7 @@ resultIsSynced authId eexamResult = (hasSchool E.&&. allSchools) E.||. (E.not_ h E.&&. synced E.^. ExamOfficeExternalResultSyncedResult E.==. eexamResult E.^. ExternalExamResultId E.&&. synced E.^. ExamOfficeExternalResultSyncedTime E.>=. eexamResult E.^. ExternalExamResultLastChanged - + examOfficeExternalExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office -> E.SqlExpr (Entity ExternalExamResult) -> E.SqlExpr (E.Value Bool) diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs index 3aaf8b7e2..75d52b3ff 100644 --- a/src/Handler/Utils/ExternalExam/Users.hs +++ b/src/Handler/Utils/ExternalExam/Users.hs @@ -18,7 +18,7 @@ import qualified Database.Esqueleto.Utils as E import Data.Csv ((.:)) import qualified Data.Csv as Csv - + import qualified Handler.Utils.ExamOffice.ExternalExam as ExternalExam import qualified Data.Text as Text @@ -181,7 +181,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do ssh = externalExamSchool coursen = externalExamCourseName examn = externalExamExamName - + uid <- requireAuthId csvName <- getMessageRender <*> pure (MsgExternalExamUserCsvName tid ssh coursen examn) isLecturer <- hasReadAccessTo $ EExamR tid ssh coursen examn EEUsersR @@ -245,7 +245,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do ++ [ Right sync | sync@(_, _, t, _) <- syncs, t <= lastChange] syncIcon :: Widget - syncIcon + syncIcon | not isSynced , not hasSyncs = mempty @@ -407,7 +407,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do yield $ ExternalExamUserCsvRegisterData pid occTime csvEUserExamResult DBCsvDiffExisting{..} -> do let ExternalExamUserTableCsv{..} = dbCsvNew - whenIsJust (zonedTimeToUTC <$> csvEUserOccurrenceStart) $ \occTime -> + whenIsJust (zonedTimeToUTC <$> csvEUserOccurrenceStart) $ \occTime -> when (occTime /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultTime) $ yield $ ExternalExamUserCsvSetTimeData (E.unValue dbCsvOldKey) occTime @@ -485,10 +485,10 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname where Entity _ User{..} = view resultUser $ existing Map.! registration - + guessUser' :: ExternalExamUserTableCsv -> DB UserId guessUser' ExternalExamUserTableCsv{..} = do - let criteria = Set.fromList $ catMaybes + let criteria = Set.fromList $ catMaybes [ GuessUserMatrikelnummer <$> csvEUserMatriculation , GuessUserDisplayName <$> csvEUserName , GuessUserSurname <$> csvEUserSurname diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index e8af2f9ad..9400a9a4b 100644 --- a/src/Handler/Utils/Files.hs +++ b/src/Handler/Utils/Files.hs @@ -13,7 +13,7 @@ import qualified Network.Minio as Minio import qualified Data.ByteString.Base64.URL as Base64 import qualified Data.ByteArray as ByteArray - + data SourceFilesException = SourceFilesMismatchedHashes @@ -34,7 +34,7 @@ sourceFile FileReference{..} = do -> maybeT (throwM SourceFilesContentUnavailable) $ do let uploadName = decodeUtf8 . Base64.encodeUnpadded $ ByteArray.convert fileContentHash uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket - fmap Just . (hoistMaybe =<<) . runAppMinio . runMaybeT $ do + fmap Just . hoistMaybe <=< runAppMinio . runMaybeT $ do objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions lift . runConduit $ Minio.gorObjectStream objRes .| C.fold | fmap (fmap fileContentHash) mFileContent /= fmap Just fileReferenceContent @@ -52,6 +52,6 @@ sourceFile FileReference{..} = do sourceFiles' :: forall file. HasFileReference file => ConduitT file File (YesodDB UniWorX) () sourceFiles' = C.mapM sourceFile' - + sourceFile' :: forall file. HasFileReference file => file -> DB File sourceFile' = sourceFile . view (_FileReference . _1) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index cc5be1768..ae8828d40 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -22,7 +22,7 @@ import Handler.Utils.I18n import Handler.Utils.Files import Import -import Data.Char (chr, ord) +import Data.Char ( chr, ord, isDigit ) import qualified Data.Char as Char import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI @@ -55,8 +55,6 @@ import Data.Aeson.Text (encodeToLazyText) import qualified Text.Email.Validate as Email import Data.Text.Lens (unpacked) - -import Data.Char (isDigit) import Text.Blaze (toMarkup) import Handler.Utils.Form.MassInput @@ -64,6 +62,8 @@ import Handler.Utils.Form.MassInput import qualified Data.Binary as Binary import qualified Data.ByteString.Base64.URL as Base64 +{-# ANN module ("HLint: ignore Use const" :: String) #-} + ---------------------------- -- Buttons (new version ) -- @@ -194,13 +194,13 @@ optionalAction' minp justAct fs@FieldSettings{..} defActive csrf = do let actionViews = over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/optional-action")) actionViews' return (doRes >>= bool (pure Nothing) (Just <$> actionRes), over _fvInput (mappend $ toWidget csrf) doView : actionViews) - + optionalActionA :: AForm Handler a -> FieldSettings UniWorX -> Maybe Bool -> AForm Handler (Maybe a) optionalActionA = optionalActionA' mpopt - + optionalActionA' :: (Field Handler Bool -> FieldSettings UniWorX -> Maybe Bool -> MForm Handler (FormResult Bool, FieldView UniWorX)) -> AForm Handler a -> FieldSettings UniWorX @@ -239,7 +239,7 @@ multiActionOpts :: forall action a. -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) multiActionOpts = multiActionOpts' mpopt - + multiAction' :: forall action a. ( RenderMessage UniWorX action, PathPiece action, Ord action ) => (Field Handler action -> FieldSettings UniWorX -> Maybe action -> MForm Handler (FormResult action, FieldView UniWorX)) @@ -263,7 +263,7 @@ multiActionField minp acts (actField, actExternal, actMessage) fs defAction csrf MsgRenderer mr <- getMsgRenderer let actionResults = view _1 <$> results - + actionViews = Map.foldrWithKey accViews [] results accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX] @@ -289,11 +289,11 @@ multiActionOpts' minp acts mActsOpts fs defAction csrf = do actsOpts <- liftHandler mActsOpts let actsOpts' = OptionList { olOptions = filter (flip Map.member acts . optionInternalValue) $ olOptions actsOpts - , olReadExternal = assertM (flip Map.member acts) . olReadExternal actsOpts + , olReadExternal = assertM (`Map.member` acts) . olReadExternal actsOpts } acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue) $ olOptions actsOpts') acts - actOption act = listToMaybe . filter (\Option{..} -> optionInternalValue == act) $ olOptions actsOpts' + actOption act = find (\Option{..} -> optionInternalValue == act) $ olOptions actsOpts' actExternal = fmap optionExternalValue . actOption actMessage = fmap (SomeMessage . optionDisplay) . actOption @@ -305,7 +305,7 @@ multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action) -> Maybe action -> AForm Handler a multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty - + multiActionAOpts :: Ord action => Map action (AForm Handler a) -> Handler (OptionList action) @@ -320,7 +320,7 @@ multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action) -> Maybe action -> WForm Handler (FormResult a) multiActionW acts fSettings defAction = aFormToWForm $ multiActionA acts fSettings defAction - + multiActionWOpts :: Ord action => Map action (AForm Handler a) -> Handler (OptionList action) @@ -335,7 +335,7 @@ multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action) -> Maybe action -> (Html -> MForm Handler (FormResult a, Widget)) multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction - + multiActionMOpts :: Ord action => Map action (AForm Handler a) -> Handler (OptionList action) @@ -400,13 +400,13 @@ explainedMultiAction' :: forall action a. explainedMultiAction' minp acts mActsOpts fs defAction csrf = do (actsOpts, actsReadExternal) <- liftHandler mActsOpts let actsOpts' = filter (flip Map.member acts . optionInternalValue . view _1) actsOpts - actsReadExternal' = assertM (flip Map.member acts) . actsReadExternal + actsReadExternal' = assertM (`Map.member` acts) . actsReadExternal acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue . view _1) actsOpts') acts - actOption act = listToMaybe . filter (\Option{..} -> optionInternalValue == act) $ view _1 <$> actsOpts' + actOption act = find (\Option{..} -> optionInternalValue == act) $ view _1 <$> actsOpts' actExternal = fmap optionExternalValue . actOption actMessage = fmap (SomeMessage . optionDisplay) . actOption - + multiActionField minp acts' (explainedSelectionField Nothing $ return (actsOpts', actsReadExternal'), actExternal, actMessage) fs defAction csrf explainedMultiAction :: forall action a. @@ -463,7 +463,7 @@ pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points pointsField = pointsFieldMinMax (Just 0) Nothing pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points -pointsFieldMax limit = pointsFieldMinMax (Just 0) limit +pointsFieldMax = pointsFieldMinMax (Just 0) pointsFieldMinMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Maybe Points -> Field m Points pointsFieldMinMax lower upper = checklower $ checkupper $ fixedPrecMinMaxField lower upper -- NOTE: fixedPrecMinMaxField uses HTML5 input attributes min & max for better browser supprt, but may not be supported by all browsers yet @@ -795,7 +795,7 @@ examGradingRuleForm prev = multiActionA actions (fslI MsgExamGradingRule) $ clas let errors | anyOf (folded . _1 . _FormSuccess) (< 0) bounds = [mr MsgPointsMustBeNonNegative] - | FormSuccess bounds' <- sequence $ map (view _1) bounds + | FormSuccess bounds' <- mapM (view _1) bounds , not $ monotone bounds' = [mr MsgPointsMustBeMonotonic] | otherwise @@ -908,7 +908,7 @@ genericFileField mkOpts = Field{..} modifySessionJson SessionFiles $ \(fromMaybe mempty -> MergeHashMap old) -> Just . MergeHashMap $ HashMap.insert ident (Map.insert fileReferenceTitle (sfId, fileReferenceModified) $ HashMap.findWithDefault mempty ident old) old - + _FileTitle :: Prism' Text FilePath _FileTitle = prism' (("f." <>) . pack) $ fmap unpack . Text.stripPrefix "f." @@ -937,7 +937,7 @@ genericFileField mkOpts = Field{..} whenIsJust fieldMaxFileSize $ \maxSize -> forM_ files $ \fInfo -> do fLength <- runConduit $ fileSource fInfo .| C.takeE (fromIntegral $ succ maxSize) .| C.lengthE when (fLength > maxSize) $ do - when (is _Just mIdent) $ + when (is _Just mIdent) $ liftHandler . runDB . runConduit $ mapM_ (transPipe lift . handleFile) files .| handleUpload opts mIdent @@ -946,7 +946,7 @@ genericFileField mkOpts = Field{..} if | invExt : _ <- filter invalidUploadExtension uploadedFilenames -> do - when (is _Just mIdent) $ + when (is _Just mIdent) $ liftHandler . runDB . runConduit $ mapM_ (transPipe lift . handleFile) files .| handleUpload opts mIdent @@ -967,7 +967,7 @@ genericFileField mkOpts = Field{..} .| C.mapMaybe (\fTitle -> fmap (fTitle, ) . assertM (views _3 $ not . fieldOptionForce) $ Map.lookup fTitle permittedFiles) .| C.filter (\(fTitle, _) -> fieldMultiple - || ( (bool (\n h -> h == pure n) elem fieldMultiple) fTitle (mapMaybe (preview _FileTitle) vals) + || ( bool (\n h -> h == pure n) elem fieldMultiple fTitle (mapMaybe (preview _FileTitle) vals) && null files ) ) @@ -985,7 +985,7 @@ genericFileField mkOpts = Field{..} .| sinkNull throwE $ SomeMessage MsgOnlyUploadOneFile | otherwise -> return $ Just fSrc' - + fieldView :: FieldViewFunc m FileUploads fieldView fieldId fieldName _attrs val req = do opts@FileField{..} <- liftHandler mkOpts @@ -1035,9 +1035,9 @@ genericFileField mkOpts = Field{..} $(widgetFile "widgets/genericFileField") unpackZips :: Text unpackZips = "unpack-zip" - - - + + + fileFieldMultiple :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m FileUploads fileFieldMultiple = genericFileField $ return FileField { fieldIdent = Nothing @@ -1057,8 +1057,8 @@ fileField = genericFileField $ return FileField , fieldAdditionalFiles = Map.empty , fieldMaxFileSize = Nothing } - -specificFileField :: UploadSpecificFile -> Field Handler FileUploads + +specificFileField :: UploadSpecificFile -> Field Handler FileUploads specificFileField UploadSpecificFile{..} = convertField (.| fixupFileTitles) id . genericFileField $ return FileField { fieldIdent = Nothing , fieldUnpackZips = FileFieldUserOption True False @@ -1072,7 +1072,7 @@ specificFileField UploadSpecificFile{..} = convertField (.| fixupFileTitles) id zipFileField :: Bool -- ^ Unpack zips? -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions - -> Field Handler FileUploads + -> Field Handler FileUploads zipFileField doUnpack permittedExtensions = genericFileField $ return FileField { fieldIdent = Nothing , fieldUnpackZips = FileFieldUserOption True doUnpack @@ -1091,23 +1091,23 @@ fileUploadForm isReq mkFs = \case UploadAny{..} -> bool aopt (\f fs _ -> Just <$> areq f fs Nothing) isReq (zipFileField unpackZips extensionRestriction) (mkFs unpackZips) Nothing UploadSpecific{..} - -> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles) + -> mergeFileSources <$> traverse specificFileForm (Set.toList $ toNullable specificFiles) where specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe FileUploads) specificFileForm spec@UploadSpecificFile{..} = bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) specificFileRequired (specificFileField spec) (fsl specificFileLabel) Nothing - mergeFileSources :: [Maybe FileUploads] -> Maybe FileUploads + mergeFileSources :: [Maybe FileUploads] -> Maybe FileUploads mergeFileSources (catMaybes -> sources) = case sources of [] -> Nothing fs -> Just $ sequence_ fs multiFileField' :: FileUploads -- ^ Permitted files in same format as produced by `multiFileField` - -> Field Handler FileUploads + -> Field Handler FileUploads multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.foldMap Set.singleton multiFileField :: Handler (Set FileReference) -- ^ Set of files that may be submitted by id-reference - -> Field Handler FileUploads + -> Field Handler FileUploads multiFileField mkPermitted = genericFileField $ mkField <$> mkPermitted where mkField permitted = FileField { fieldIdent = Nothing @@ -1237,7 +1237,7 @@ dayTimeField fs mutc = do fieldTimeFormat :: String -- fieldTimeFormat = "%e.%m.%y %k:%M" fieldTimeFormat = "%Y-%m-%dT%H:%M:%S" - + localTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m LocalTime localTimeField = Field { fieldParse = parseHelperGen readTime @@ -1343,7 +1343,7 @@ sectionedFuncForm mkSection mkForm FieldSettings{fsName = _, fsAttrs = _, ..} is -> return () lift $ tell fs aFormToWForm $ Map.union <$> wFormToAForm (pure res) <*> acc - + funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX]) funcFieldView (res, formView) = do mr <- getMessageRender @@ -1437,7 +1437,7 @@ optionsCryptoIdF (otoList -> iVals) toExtVal toMsg , optionExternalValue = toPathPiece (cID :: CryptoUUID k) , optionInternalValue } - + examOccurrenceField :: ( MonadHandler m , HandlerSite m ~ UniWorX @@ -1445,7 +1445,7 @@ examOccurrenceField :: ( MonadHandler m => ExamId -> Field m ExamOccurrenceId examOccurrenceField eid - = hoistField liftHandler . selectField . (fmap $ fmap entityKey) + = hoistField liftHandler . selectField . fmap (fmap entityKey) $ optionsPersistCryptoId [ ExamOccurrenceExam ==. eid ] [ Asc ExamOccurrenceName ] examOccurrenceName @@ -1469,7 +1469,7 @@ data MultiUserInvitationMode | MUILookupAnyUser (Maybe (E.SqlQuery (E.SqlExpr (Entity User)))) | MUILookupSuggested (SomeMessage UniWorX) (E.SqlQuery (E.SqlExpr (Entity User))) - + multiUserInvitationField :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX @@ -1553,7 +1553,7 @@ multiUserField onlySuggested suggestions = Field{..} whenIsJust suggestions $ \suggestions' -> do suggestedEmails <- fmap (Map.assocs . Map.fromListWith min . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDB . E.select $ do user <- suggestions' - return $ ( E.case_ + return ( E.case_ [ E.when_ (unique UserDisplayEmail user) E.then_ (user E.^. UserDisplayEmail) , E.when_ (unique UserEmail user) @@ -1681,7 +1681,7 @@ examResultGradeField = flip examResultField $ do ) } ] - + examResultPassedField :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX @@ -1699,7 +1699,7 @@ examResultPassedField = flip examResultField $ do ) } ] - + examResultPassedGradeField :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX @@ -1739,7 +1739,7 @@ examResultModeField :: forall m. examResultModeField optMsg ExamGradingGrades = convertField (fmap Right) (fmap $ either (review passingGrade) id) $ examResultGradeField optMsg examResultModeField optMsg ExamGradingPass = convertField (fmap Left) (fmap $ either id (view passingGrade)) $ examResultPassedField optMsg examResultModeField optMsg ExamGradingMixed = examResultPassedGradeField optMsg - + examGradeField :: forall m. ( MonadHandler m @@ -1768,7 +1768,7 @@ examField :: forall m. , HandlerSite m ~ UniWorX ) => Maybe (SomeMessage UniWorX) -> CourseId -> Field m ExamId -examField optMsg cId = hoistField liftHandler . selectField' optMsg . (fmap $ fmap entityKey) $ +examField optMsg cId = hoistField liftHandler . selectField' optMsg . fmap (fmap entityKey) $ optionsPersistCryptoId [ExamCourse ==. cId] [Asc ExamName] examName @@ -1814,7 +1814,7 @@ csvFormatOptionsForm fs mPrev = hoistAForm liftHandler . multiActionA csvActs fs delimiterOpts = do MsgRenderer mr <- getMsgRenderer let - opts = + opts = [ (MsgCsvDelimiterNull, '\0') , (MsgCsvDelimiterTab, '\t') , (MsgCsvDelimiterComma, ',') @@ -1834,13 +1834,13 @@ csvFormatOptionsForm fs mPrev = hoistAForm liftHandler . multiActionA csvActs fs | (msg, c) <- opts ] return OptionList{..} - + lineEndOpts :: Handler (OptionList Bool) lineEndOpts = optionsPathPiece [ (MsgCsvCrLf, True ) , (MsgCsvLf, False) ] - + quoteOpts :: Handler (OptionList Quoting) quoteOpts = optionsF [ QuoteMinimal @@ -1870,7 +1870,7 @@ csvOptionsForm mPrev = hoistAForm liftHandler $ CsvOptions <$> csvFormatOptionsForm (fslI MsgCsvFormatOptions & setTooltip MsgCsvOptionsTip) (csvFormat <$> mPrev) <*> apopt checkBoxField (fslI MsgCsvTimestamp & setTooltip MsgCsvTimestampTip) (csvTimestamp <$> mPrev) - + courseSelectForm :: forall ident handler. ( PathPiece ident , MonadHandler handler, HandlerSite handler ~ UniWorX @@ -1894,7 +1894,7 @@ courseSelectForm query coursePred miButtonAction' miIdent' fSettings fRequired m , E.asc $ course E.^. CourseName ] return course - + miAdd' nudge btn csrf = do let courseOptions = optionsCryptoIdE query' (\Course{..} -> MsgCourseOption courseTerm courseSchool courseName) >>= fmap (fmap entityKey . mkOptionList) . filterM (coursePred . optionInternalValue) . olOptions @@ -1925,7 +1925,7 @@ embedRenderMessageVariant ''UniWorX ''CourseParticipantStateIsActive $ \case finitePathPiece ''CourseParticipantStateIsActive ["inactive", "active"] makeWrapped ''CourseParticipantStateIsActive - + courseParticipantStateIsActiveField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (SomeMessage UniWorX) -> Field m Bool courseParticipantStateIsActiveField optMsg = hoistField liftHandler . isoField (_Wrapped @CourseParticipantStateIsActive) $ radioGroupField optMsg optionsFinite diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index fd1a79895..06e856324 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -37,6 +37,8 @@ import Text.Hamlet (hamletFile) import Algebra.Lattice.Ordered (Ordered(..)) +{-# ANN module ("HLint: ignore Use const" :: String) #-} + $(mapM tupleBoxCoord [2..4]) @@ -149,7 +151,7 @@ instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) wher (\ts -> let ks = Set.mapMonotonic fst ts in fmap MapLiveliness . sequence $ Map.fromSet (\k -> preview liveCoords . Set.mapMonotonic snd $ Set.filter ((== k) . fst) ts) ks) -type MassInputDelete liveliness = forall m a. Applicative m => Map (BoxCoord liveliness) a -> (BoxCoord liveliness) -> m (Map (BoxCoord liveliness) (BoxCoord liveliness)) +type MassInputDelete liveliness = forall m a. Applicative m => Map (BoxCoord liveliness) a -> BoxCoord liveliness -> m (Map (BoxCoord liveliness) (BoxCoord liveliness)) miDeleteList :: MassInputDelete ListLength @@ -330,9 +332,9 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR guard $ isn't _FormMissing btnRes res miAdd' = traverse ($ mempty) $ miAdd miCoord dimIx nudgeAddWidgetName btnView - addRes'' <- miAdd' & mapped . _Just . _1 %~ wBtnRes + addRes'' <- miAdd' <&> (_Just . _1) %~ wBtnRes addRes' <- fmap join . for addRes'' $ bool (return . Just) (\(res, _view) -> set (_Just . _1) res <$> local (set _1 Nothing) miAdd') (is (_Just . _FormSuccess) (fst <$> addRes'') || is _FormMissing btnRes) - let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just) $ fmap fst addRes', fmap snd addRes') + let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just . fst) addRes', fmap snd addRes') case remDims of [] -> return dimRes' ((_, BoxDimension dim) : _) -> do @@ -373,7 +375,7 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR delShapeUpdate | [FormSuccess shapeUpdate'] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst delResults = Just shapeUpdate' | otherwise = Nothing - delShape = traverse (flip Map.lookup addedShape) =<< delShapeUpdate + delShape = traverse (`Map.lookup` addedShape) =<< delShapeUpdate let shapeChanged = Fold.any (isn't _FormMissing . view _1) addResults || Fold.any (is _FormSuccess . view _1) delResults @@ -490,7 +492,7 @@ massInputList :: forall handler cellResult ident msg. -> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX)) massInputList field fieldSettings onMissing miButtonAction miIdent miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf -> - return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax pRes) (), toWidget csrf >> fvWidget submitBtn) + return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 (succ . fst) $ Map.lookupMax pRes) (), toWidget csrf >> fvWidget submitBtn) , miCell = \pos () iRes nudge csrf -> over _2 (\fv -> $(widgetFile "widgets/massinput/list/cell")) <$> mreqMsg field (fieldSettings pos & addName (nudge "field")) onMissing iRes , miDelete = miDeleteList @@ -544,7 +546,7 @@ massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequire miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget)) - miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf' + miAdd _pos _dim nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView) doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData)) doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems @@ -599,7 +601,7 @@ massInputAccumW :: forall handler cellData ident. massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev = mFormToWForm $ massInputAccum miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty - + -- | Wrapper around `massInput` for the common case, that we just want a list of data with existing data modified the same way as new data is added massInputAccumEdit :: forall handler cellData ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX @@ -622,7 +624,7 @@ massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fReq miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget)) - miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf' + miAdd _pos _dim nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView) doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData)) doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems diff --git a/src/Handler/Utils/Form/MassInput/TH.hs b/src/Handler/Utils/Form/MassInput/TH.hs index dac5203b0..3170f8204 100644 --- a/src/Handler/Utils/Form/MassInput/TH.hs +++ b/src/Handler/Utils/Form/MassInput/TH.hs @@ -30,7 +30,7 @@ tupleBoxCoord tupleDim = do instanceD tCxt ([t|IsBoxCoord|] `appT` tupleType) [ funD 'boxDimensions - [ clause [] (normalB . foldr1 (\ds1 ds2 -> [e|(++)|] `appE` ds1 `appE` ds2) . map (\field -> [e|map (\(BoxDimension dim) -> BoxDimension $ $(field) . dim) boxDimensions|]) $ map (fieldLenses !!) [0..pred tupleDim]) [] + [ clause [] (normalB . foldr1 (\ds1 ds2 -> [e|(++)|] `appE` ds1 `appE` ds2) $ map (\field -> [e|map (\(BoxDimension dim) -> BoxDimension $ $(fieldLenses !! field) . dim) boxDimensions|]) [0..pred tupleDim]) [] ] , funD 'boxOrigin [ clause [] (normalB . tupE $ replicate tupleDim [e|boxOrigin|]) [] diff --git a/src/Handler/Utils/I18n.hs b/src/Handler/Utils/I18n.hs index 0394aa578..aaf7132f4 100644 --- a/src/Handler/Utils/I18n.hs +++ b/src/Handler/Utils/I18n.hs @@ -58,13 +58,13 @@ i18nWidgetFilesAvailable' basename = do let fileKinds' = fmap (pack . dropExtension . takeBaseName &&& toTranslation . pack . takeBaseName) availableFiles fileKinds :: Map Text [Text] fileKinds = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . Set.toList <$> Map.fromListWith Set.union [ (kind, Set.singleton l) | (kind, Just l) <- fileKinds' ] - toTranslation fName = listToMaybe . sortOn length . mapMaybe (flip Text.stripPrefix fName . (<>".")) $ map fst fileKinds' + toTranslation fName = (listToMaybe . sortOn length) (mapMaybe ((flip Text.stripPrefix fName . (<>".")) . fst) fileKinds') iforM fileKinds $ \kind -> maybe (fail $ "‘" <> i18nDirectory <> "’ has no translations for ‘" <> unpack kind <> "’") return . NonEmpty.nonEmpty i18nWidgetFilesAvailable :: FilePath -> Q Exp i18nWidgetFilesAvailable = TH.lift <=< i18nWidgetFilesAvailable' - + i18nWidgetFiles :: FilePath -> Q Exp i18nWidgetFiles basename = do availableTranslations' <- i18nWidgetFilesAvailable' basename diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index 7d424420d..2a9f90703 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -274,7 +274,7 @@ sourceInvitations :: forall junction m backend. -> ConduitT () (UserEmail, InvitationDBData junction) (ReaderT backend m) () sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode where - decode (Entity _ (Invitation{invitationEmail, invitationData})) + decode (Entity _ Invitation{invitationEmail, invitationData}) = case fromJSON invitationData of JSON.Success dbData -> return (invitationEmail, dbData) JSON.Error str -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str @@ -291,7 +291,7 @@ sourceInvitationsF :: forall junction map m backend. , PersistQueryRead backend ) => Key (InvitationFor junction) - -> ReaderT backend m map + -> ReaderT backend m map sourceInvitationsF forKey = runConduit $ sourceInvitations forKey .| C.foldMap (uncurry singletonMap) @@ -309,7 +309,7 @@ deleteInvitations :: forall junction m backend. => Key (InvitationFor junction) -> ConduitT UserEmail Void (ReaderT backend m) () deleteInvitations k = C.foldMap Set.singleton >>= lift . deleteInvitationsF @junction k - + deleteInvitationsF :: forall junction m mono backend. ( IsInvitableJunction junction , MonadIO m @@ -322,7 +322,7 @@ deleteInvitationsF :: forall junction m mono backend. -> ReaderT backend m () -- | Non-conduit version of `deleteInvitations` deleteInvitationsF invitationFor (otoList -> emailList) - = deleteWhere [InvitationEmail <-. nub emailList, InvitationFor ==. invRef @junction invitationFor] + = deleteWhere [InvitationEmail <-. nub emailList, InvitationFor ==. invRef @junction invitationFor] deleteInvitation :: forall junction m backend. ( IsInvitableJunction junction diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index 3116d6f18..6160965b4 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/src/Handler/Utils/Memcached.hs @@ -44,7 +44,7 @@ import qualified Control.Concurrent.TokenBucket as Concurrent (TokenBucket, newT import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent.STM.Delay - + import qualified Crypto.Saltine.Class as Saltine import qualified Crypto.Saltine.Internal.ByteSizes as Saltine import qualified Crypto.Saltine.Core.AEAD as AEAD @@ -104,7 +104,7 @@ memcachedByGet :: forall a k m. memcachedByGet k = runMaybeT $ do (aeadKey, conn) <- MaybeT $ getsYesod appMemcached let cKey = memcachedKey aeadKey (Proxy @a) k - + encVal <- fmap toStrict . hoist liftIO . catchMaybeT (Proxy @Memcached.MemcachedException) $ Memcached.get_ cKey conn $logDebugS "memcached" "Cache hit" @@ -115,7 +115,7 @@ memcachedByGet k = runMaybeT $ do decrypted <- hoistMaybe $ AEAD.aeadOpen aeadKey nonce encrypted cKey $logDebugS "memcached" "Decryption valid" - + case Binary.decodeOrFail $ fromStrict decrypted of Right (unconsumed, _, v) | null unconsumed -> do @@ -155,7 +155,7 @@ memcachedByInvalidate k _ = maybeT_ $ do newtype MemcachedUnkeyed a = MemcachedUnkeyed { unMemcachedUnkeyed :: a } deriving (Typeable) deriving newtype (Eq, Ord, Show, Binary) - + memcachedGet :: ( MonadHandler m, HandlerSite m ~ UniWorX , Typeable a, Binary a ) @@ -209,7 +209,7 @@ newtype MemcachedUnkeyedLoc a = MemcachedUnkeyedLoc { unMemcachedUnkeyedLoc :: a memcachedHere :: Q Exp memcachedHere = do loc <- location - [e| \mExp -> fmap unMemcachedUnkeyedLoc . memcachedBy mExp loc . fmap MemcachedUnkeyedLoc |] + [e| \mExp -> fmap unMemcachedUnkeyedLoc . memcachedBy mExp loc . fmap MemcachedUnkeyedLoc |] newtype MemcachedKeyedLoc a = MemcachedKeyedLoc { unMemcachedKeyedLoc :: a } deriving (Typeable) @@ -234,7 +234,7 @@ hashableDynamic :: forall a. ( Typeable a, Hashable a, Eq a ) => a -> HashableDynamic hashableDynamic v = HashableDynamic (typeOf v) v - + memcachedLimit :: TVar (HashMap HashableDynamic Concurrent.TokenBucket) memcachedLimit = unsafePerformIO . newTVarIO $ HashMap.empty {-# NOINLINE memcachedLimit #-} @@ -267,7 +267,7 @@ memcachedLimitedWith (doGet, doSet) liftAct (hashableDynamic -> lK) burst rate t sufficientTokens <- liftIO $ Concurrent.tokenBucketTryAlloc bucket burst rate tokens $logDebugS "memcachedLimitedWith" $ "Sufficient tokens: " <> tshow sufficientTokens guard sufficientTokens - + liftAct $ do res <- act doSet res @@ -285,7 +285,7 @@ memcachedLimited :: forall a m. -> m a -> m (Maybe a) memcachedLimited burst rate tokens mExp = memcachedLimitedWith (memcachedGet, memcachedSet mExp) lift (Proxy @a) burst rate tokens - + memcachedLimitedKey :: forall a k' m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m @@ -300,7 +300,7 @@ memcachedLimitedKey :: forall a k' m. -> m a -> m (Maybe a) memcachedLimitedKey lK burst rate tokens mExp = memcachedLimitedWith (memcachedGet, memcachedSet mExp) lift lK burst rate tokens - + memcachedLimitedBy :: forall a k m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m @@ -315,7 +315,7 @@ memcachedLimitedBy :: forall a k m. -> m a -> m (Maybe a) memcachedLimitedBy burst rate tokens mExp k = memcachedLimitedWith (memcachedByGet k, memcachedBySet mExp k) lift (Proxy @a) burst rate tokens - + memcachedLimitedKeyBy :: forall a k' k m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m @@ -337,7 +337,7 @@ memcachedLimitedHere :: Q Exp memcachedLimitedHere = do loc <- location [e| \burst rate tokens mExp -> fmap (fmap unMemcachedUnkeyedLoc) . memcachedLimitedBy burst rate tokens mExp loc . fmap MemcachedUnkeyedLoc |] - + memcachedLimitedKeyHere :: Q Exp memcachedLimitedKeyHere = do loc <- location @@ -347,7 +347,7 @@ memcachedLimitedByHere :: Q Exp memcachedLimitedByHere = do loc <- location [e| \burst rate tokens mExp k -> fmap (fmap unMemcachedKeyedLoc) . memcachedLimitedBy burst rate tokens mExp (loc, k) . fmap MemcachedKeyedLoc |] - + memcachedLimitedKeyByHere :: Q Exp memcachedLimitedKeyByHere = do loc <- location @@ -357,7 +357,7 @@ memcachedLimitedKeyByHere = do data AsyncTimeoutException = AsyncTimeoutReturnTypeDoesNotMatchComputationKey deriving (Show, Typeable) deriving anyclass (Exception) - + data DynamicAsync = forall a. DynamicAsync !(TypeRep a) !(Async a) instance Eq DynamicAsync where @@ -389,9 +389,9 @@ liftAsyncTimeout dt (hashableDynamic -> cK) act = ifNotM memcachedAvailable (lif Nothing -> do startAct <- liftIO newEmptyTMVarIO act' <- async $ do - $logDebugS "liftAsyncTimeout" $ "Waiting for confirmation..." + $logDebugS "liftAsyncTimeout" "Waiting for confirmation..." atomically $ takeTMVar startAct - $logDebugS "liftAsyncTimeout" $ "Confirmed." + $logDebugS "liftAsyncTimeout" "Confirmed." act act'' <- atomically $ do hm <- readTVar memcachedAsync @@ -406,7 +406,7 @@ liftAsyncTimeout dt (hashableDynamic -> cK) act = ifNotM memcachedAvailable (lif State.put old return $ Just old' Nothing -> return $ Just new - + (hm', act'') <- runStateT (HashMap.alterF go cK hm) act' writeTVar memcachedAsync $! hm' return act'' @@ -460,7 +460,7 @@ memcachedTimeoutBy mExp dt cK k = memcachedTimeoutWith (memcachedByGet k, memcac memcachedTimeoutHere :: Q Exp memcachedTimeoutHere = do loc <- location - [e| \mExp dt cK -> fmap unMemcachedUnkeyedLoc . memcachedTimeoutBy mExp dt cK loc . fmap MemcachedUnkeyedLoc |] + [e| \mExp dt cK -> fmap unMemcachedUnkeyedLoc . memcachedTimeoutBy mExp dt cK loc . fmap MemcachedUnkeyedLoc |] memcachedTimeoutByHere :: Q Exp memcachedTimeoutByHere = do @@ -483,7 +483,7 @@ memcachedLimitedTimeout :: forall a k'' m. -> m a -> m (Maybe a) memcachedLimitedTimeout burst rate tokens mExp dt cK = memcachedLimitedWith (memcachedGet, memcachedSet mExp) (liftAsyncTimeout dt cK) (Proxy @a) burst rate tokens - + memcachedLimitedKeyTimeout :: forall a k' k'' m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m @@ -502,7 +502,7 @@ memcachedLimitedKeyTimeout :: forall a k' k'' m. -> m a -> m (Maybe a) memcachedLimitedKeyTimeout lK burst rate tokens mExp dt cK = memcachedLimitedWith (memcachedGet, memcachedSet mExp) (liftAsyncTimeout dt cK) lK burst rate tokens - + memcachedLimitedTimeoutBy :: forall a k'' k m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m @@ -521,7 +521,7 @@ memcachedLimitedTimeoutBy :: forall a k'' k m. -> m a -> m (Maybe a) memcachedLimitedTimeoutBy burst rate tokens mExp dt cK k = memcachedLimitedWith (memcachedByGet k, memcachedBySet mExp k) (liftAsyncTimeout dt cK) (Proxy @a) burst rate tokens - + memcachedLimitedKeyTimeoutBy :: forall a k' k'' k m. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m @@ -547,7 +547,7 @@ memcachedLimitedTimeoutHere :: Q Exp memcachedLimitedTimeoutHere = do loc <- location [e| \burst rate tokens mExp dt cK -> fmap (fmap unMemcachedUnkeyedLoc) . memcachedLimitedTimeoutBy burst rate tokens mExp dt cK loc . fmap MemcachedUnkeyedLoc |] - + memcachedLimitedKeyTimeoutHere :: Q Exp memcachedLimitedKeyTimeoutHere = do loc <- location @@ -557,7 +557,7 @@ memcachedLimitedTimeoutByHere :: Q Exp memcachedLimitedTimeoutByHere = do loc <- location [e| \burst rate tokens mExp dt cK k -> fmap (fmap unMemcachedKeyedLoc) . memcachedLimitedTimeoutBy burst rate tokens mExp dt cK (loc, k) . fmap MemcachedKeyedLoc |] - + memcachedLimitedKeyTimeoutByHere :: Q Exp memcachedLimitedKeyTimeoutByHere = do loc <- location diff --git a/src/Handler/Utils/Pandoc.hs b/src/Handler/Utils/Pandoc.hs index 8ee7e2cab..e4f3d49e1 100644 --- a/src/Handler/Utils/Pandoc.hs +++ b/src/Handler/Utils/Pandoc.hs @@ -33,7 +33,7 @@ htmlField' :: MonadLogger m => HtmlFieldKind -> Field m Html htmlField' fieldKind = Field{..} where fieldEnctype = UrlEncoded - + fieldParse (t : _) _ = return . fmap (assertM' $ not . null . renderHtml) . parseMarkdown $ Text.strip t fieldParse [] _ = return $ Right Nothing diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 90d7d0375..4a2d5615b 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -147,7 +147,7 @@ isRatingFile (takeFileName -> fName) = liftHandler . runMaybeT $ do cryptoIdChars :: Set (CI Char) cryptoIdChars = Set.fromList . map CI.mk $ "uwa" ++ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567" - + isRatingFileName app cID = is _Just $ do [CI.mk -> dWord, number, CI.mk -> extension] <- pure . filter (not . Text.null) . Text.split (not . Char.isAlphaNum) $ Text.pack fName guard $ Text.all (flip Set.member cryptoIdChars . CI.mk) number diff --git a/src/Handler/Utils/Rating/Format.hs b/src/Handler/Utils/Rating/Format.hs index c0059c2f9..fd8ab2fb5 100644 --- a/src/Handler/Utils/Rating/Format.hs +++ b/src/Handler/Utils/Rating/Format.hs @@ -29,8 +29,6 @@ import qualified Data.YAML.Event as YAML.Event import qualified Data.YAML.Token as YAML (Encoding(..)) import Data.YAML.Aeson () -- ToYAML Value -import Data.List (elemIndex) - import Control.Monad.Trans.State.Lazy (evalState) import qualified System.FilePath.Cryptographic as Explicit @@ -49,7 +47,7 @@ data PrettifyState | PrettifyComment deriving (Eq, Ord, Read, Show, Generic, Typeable) - + formatRating :: MsgRendererS UniWorX -> DateTimeFormatter -> CryptoFileNameSubmission -> Rating -> Lazy.ByteString formatRating (MsgRenderer mr) DateTimeFormatter{..} cID Rating{ ratingValues = Rating'{..}, .. } = mconcat [ prettyYAML @@ -57,7 +55,7 @@ formatRating (MsgRenderer mr) DateTimeFormatter{..} cID Rating{ ratingValues = R ] where ensureNewline t = Text.strip t <> "\n" - + uglyYAML = YAML.Event.writeEvents YAML.UTF8 $ concat [ [ YAML.Event.StreamStart , YAML.Event.DocumentStart $ YAML.Event.DirEndMarkerVersion 2 @@ -142,7 +140,7 @@ formatRating (MsgRenderer mr) DateTimeFormatter{..} cID Rating{ ratingValues = R pos1' = min pos1 mLength pos2' = min pos2 mLength in (before <> ann1 <> fromStrict (encodeUtf8 event'') <> fromStrict (encodeUtf8 $ ann2 ws) <> after, pos1') - + transduce :: PrettifyState -> YAML.Event.Event -> ((Text, Text -> Text), PrettifyState) transduce PrettifyInitial YAML.Event.MappingStart{} = (("# " <> mr MsgRatingYAMLMetaComment <> "\n", id), PrettifyMetadata 0) transduce PrettifyInitial _ = ((mempty, id), PrettifyInitial) @@ -195,8 +193,8 @@ instance ns ~ CryptoIDNamespace (CI FilePath) SubmissionId => YAML.FromYAML (May -> ( Rating'{ ratingComment = fromMaybe ratingComment'' ratingComment', .. } , cID ) - - + + parseRating :: MonadCatch m => File -> m (Rating', Maybe CryptoFileNameSubmission) parseRating f@File{ fileContent = Just (fromStrict -> input), .. } = handle onFailure . handle (throwM . RatingParseException) . handleIf isYAMLUnicodeError (\(ErrorCall msg) -> throwM $ RatingYAMLNotUnicode msg) $ do let evStream = YAML.Event.parseEvents input diff --git a/src/Handler/Utils/Rating/Format/Legacy.hs b/src/Handler/Utils/Rating/Format/Legacy.hs index 0bfa93af1..bd523d06a 100644 --- a/src/Handler/Utils/Rating/Format/Legacy.hs +++ b/src/Handler/Utils/Rating/Format/Legacy.hs @@ -54,7 +54,7 @@ formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let , pure $ pretty ratingComment ] in Lazy.Text.encodeUtf8 . (<> "\n") $ displayT doc - + parseRating :: MonadCatch m => File -> m Rating' parseRating File{ fileContent = Just input, .. } = handle (throwM . RatingParseLegacyException) $ do inputText <- either (throwM . RatingNotUnicode) return $ Text.decodeUtf8' input diff --git a/src/Handler/Utils/SchoolLdap.hs b/src/Handler/Utils/SchoolLdap.hs index 782d533c9..b8e9bcbf8 100644 --- a/src/Handler/Utils/SchoolLdap.hs +++ b/src/Handler/Utils/SchoolLdap.hs @@ -10,7 +10,7 @@ import Text.Parsec.Text import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set - + parseLdapSchools :: Text -> Either ParseError (Set (CI Text)) parseLdapSchools = parse pLdapSchools "" @@ -28,4 +28,4 @@ pSegment = do fragStart pack <$> manyTill anyChar (try (lookAhead $ char ',' >> fragStart) <|> eof) - + diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index a138fc69c..52d59082f 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -16,7 +16,7 @@ parseStudyFeatures :: UserId -> UTCTime -> Text -> Either ParseError [StudyFeatu parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) (unpack key) where Ldap.Attr key = ldapUserStudyFeatures - + parseSubTermsSemester :: Text -> Either ParseError (StudyTermsId, Int) parseSubTermsSemester = parse (pLMUTermsSemester <* eof) (unpack key) where @@ -44,7 +44,7 @@ pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do return StudyFeatures{..} pStudyFeature `sepBy1` char '#' - + pKey :: Parser Int pKey = decimal diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index e29f9ce50..a63686f84 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -169,7 +169,7 @@ planSubmissions sid restriction = do targetSubmissionData = set _1 Nothing <$> Map.restrictKeys submissionData targetSubmissions oldSubmissionData = Map.withoutKeys submissionData targetSubmissions - whenIsJust (fromNullable =<< fmap (`Set.difference` targetSubmissions) restriction) $ \missing -> + whenIsJust (fromNullable . (`Set.difference` targetSubmissions) =<< restriction) $ \missing -> throwM $ SubmissionsNotFound missing let @@ -236,7 +236,7 @@ planSubmissions sid restriction = do | otherwise = Map.keysSet $ Map.filter (views _byProportion (/= 0)) sheetCorrectors - when (not $ null acceptableCorrectors) $ do + unless (null acceptableCorrectors) $ do deficits <- sequence . flip Map.fromSet acceptableCorrectors $ withSubmissionData . calculateDeficit let bestCorrectors :: Set UserId @@ -570,7 +570,7 @@ sinkSubmission userId mExists isUpdate = do sinkSubmission' :: SubmissionId -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) () sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case - Left file@(FileReference{..}) -> do + Left file@FileReference{..} -> do $logDebugS "sinkSubmission" . tshow $ (submissionId, fileReferenceTitle) alreadySeen <- gets (Set.member fileReferenceTitle . sinkFilenames) @@ -587,7 +587,7 @@ sinkSubmission userId mExists isUpdate = do , submissionFileIsUpdate sf == isUpdate ] underlyingFiles = [ t | t@(Entity _ sf) <- otherVersions - , submissionFileIsUpdate sf == False + , not (submissionFileIsUpdate sf) ] anyChanges | not (null collidingFiles) = any (/~ file) [ view (_FileReference . _1) sf | Entity _ sf <- collidingFiles ] @@ -654,7 +654,7 @@ sinkSubmission userId mExists isUpdate = do -- -- 'fileModified' is simply stored and never inspected while -- 'submissionChanged' is always set to @now@. - let anyChanges = any (\f -> f submission submission') $ + let anyChanges = any (\f -> f submission submission') [ (/=) `on` submissionRatingPoints , (/=) `on` submissionRatingComment , (/=) `on` submissionRatingDone @@ -665,13 +665,13 @@ sinkSubmission userId mExists isUpdate = do touchSubmission Sheet{..} <- lift . getJust $ submissionSheet submission' - + mapM_ (throwM . RatingSubmissionException cID . RatingValidityException) $ validateRating sheetType r' when (submissionRatingDone submission' && not (submissionRatingDone submission)) $ tellSt mempty { sinkSubmissionNotifyRating = Any True } lift $ replace submissionId submission' - sheetId <- lift $ getSheetId + sheetId <- lift getSheetId lift $ audit $ TransactionSubmissionEdit submissionId sheetId where a /~ b = not $ a ~~ b @@ -695,16 +695,16 @@ sinkSubmission userId mExists isUpdate = do touchSubmission :: StateT SubmissionSinkState (YesodJobDB UniWorX) () touchSubmission = do alreadyTouched <- gets $ getAny . sinkSubmissionTouched - when (not alreadyTouched) $ do + unless alreadyTouched $ do now <- liftIO getCurrentTime - case isUpdate of - False -> lift . insert_ $ SubmissionEdit userId now submissionId - True -> do - Submission{submissionRatingTime} <- lift $ getJust submissionId - when (is _Just submissionRatingTime) $ - lift $ update submissionId [ SubmissionRatingTime =. Just now ] + if + | isUpdate -> do + Submission{submissionRatingTime} <- lift $ getJust submissionId + when (is _Just submissionRatingTime) $ + lift $ update submissionId [ SubmissionRatingTime =. Just now ] + | otherwise -> lift . insert_ $ SubmissionEdit userId now submissionId tellSt $ mempty{ sinkSubmissionTouched = Any True } - + getSheetId :: MonadIO m => ReaderT SqlBackend m SheetId getSheetId = case mExists of Left shid @@ -716,15 +716,36 @@ sinkSubmission userId mExists isUpdate = do finalize SubmissionSinkState{..} = do missingFiles <- E.select . E.from $ \sf -> E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId - when (not isUpdate) $ + unless isUpdate $ E.where_ . E.not_ $ sf E.^. SubmissionFileIsUpdate E.where_ $ sf E.^. SubmissionFileTitle `E.notIn` E.valList (Set.toList sinkFilenames) E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] return sf - case isUpdate of - False -> do + if + | isUpdate -> forM_ missingFiles $ \(Entity sfId SubmissionFile{..}) -> do + shadowing <- existsBy $ UniqueSubmissionFile submissionFileSubmission submissionFileTitle False + + if + | not shadowing -> do + delete sfId + audit $ TransactionSubmissionFileDelete sfId submissionId + | submissionFileIsUpdate -> do + update sfId [ SubmissionFileContent =. Nothing, SubmissionFileIsDeletion =. True ] + audit $ TransactionSubmissionFileEdit sfId submissionId + | otherwise -> do + now <- liftIO getCurrentTime + sfId' <- insert $ SubmissionFile + { submissionFileSubmission = submissionId + , submissionFileTitle + , submissionFileModified = now + , submissionFileContent = Nothing + , submissionFileIsUpdate = True + , submissionFileIsDeletion = True + } + audit $ TransactionSubmissionFileEdit sfId' submissionId + | otherwise -> do shadowed <- selectKeysList [ SubmissionFileSubmission ==. submissionId , SubmissionFileIsUpdate ==. False @@ -733,27 +754,6 @@ sinkSubmission userId mExists isUpdate = do forM_ shadowed $ \sfId' -> do delete sfId' audit $ TransactionSubmissionFileDelete sfId' submissionId - True -> forM_ missingFiles $ \(Entity sfId SubmissionFile{..}) -> do - shadowing <- existsBy $ UniqueSubmissionFile submissionFileSubmission submissionFileTitle False - - if - | not shadowing -> do - delete sfId - audit $ TransactionSubmissionFileDelete sfId submissionId - | submissionFileIsUpdate -> do - update sfId [ SubmissionFileContent =. Nothing, SubmissionFileIsDeletion =. True ] - audit $ TransactionSubmissionFileEdit sfId submissionId - | otherwise -> do - now <- liftIO getCurrentTime - sfId' <- insert $ SubmissionFile - { submissionFileSubmission = submissionId - , submissionFileTitle - , submissionFileModified = now - , submissionFileContent = Nothing - , submissionFileIsUpdate = True - , submissionFileIsDeletion = True - } - audit $ TransactionSubmissionFileEdit sfId' submissionId if | isUpdate @@ -829,7 +829,7 @@ sinkMultiSubmission userId isUpdate = do | otherwise = return Nothing Dual (Alt msId) <- lift . flip foldMapM segments' $ \seg -> Dual . Alt <$> lift (tryDecrypt seg) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileReferenceTitle) ] return (msId, fp) - (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileReferenceTitle + (msId, joinPath -> fileTitle') <- foldM acc (Nothing, []) $ splitDirectories fileReferenceTitle case msId of Nothing -> do $logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileReferenceTitle, msId, fileTitle') @@ -838,7 +838,7 @@ sinkMultiSubmission userId isUpdate = do cID <- encrypt sId lift . handle (throwM . SubmissionSinkException cID (Just fileReferenceTitle)) $ feed sId $ Left f{ fileReferenceTitle = fileTitle' } - when (not $ null ignoredFiles) $ do + unless (null ignoredFiles) $ do mr <- (toHtml .) <$> getMessageRender addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) lift . fmap Set.fromList . forM (Map.toList sinks) $ \(sId, sink) -> do @@ -899,7 +899,7 @@ submissionDeleteRoute drRecords = DeleteRoute uid <- maybeAuthId subUsers <- selectList [SubmissionUserSubmission ==. subId] [] if - | length subUsers >= 1 + | not $ null subUsers , maybe True (flip any subUsers . (. submissionUserUser . entityVal) . (/=)) uid -> Just <$> messageI Warning (MsgSubmissionDeleteCosubmittorsWarning $ length infos) | otherwise diff --git a/src/Handler/Utils/Table.hs b/src/Handler/Utils/Table.hs index bf4ca6f13..65880ae92 100644 --- a/src/Handler/Utils/Table.hs +++ b/src/Handler/Utils/Table.hs @@ -1,7 +1,7 @@ module Handler.Utils.Table ( module Handler.Utils.Table ) where - + import Handler.Utils.Table.Pagination as Handler.Utils.Table import Handler.Utils.Table.Columns as Handler.Utils.Table import Handler.Utils.Table.Cells as Handler.Utils.Table diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index a586fedfd..df7916e2c 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -120,7 +120,7 @@ colSchoolShort resultSsh = Colonnade.singleton (fromSortable header) body sortSchoolShort :: OpticSortColumn SchoolId sortSchoolShort querySsh = singletonMap "school-short" . SortColumn $ view querySsh - + colSchoolName :: OpticColonnade SchoolName colSchoolName resultSn = Colonnade.singleton (fromSortable header) body where @@ -129,7 +129,7 @@ colSchoolName resultSn = Colonnade.singleton (fromSortable header) body sortSchoolName :: OpticSortColumn SchoolName sortSchoolName querySn = singletonMap "school-name" . SortColumn $ view querySn - + fltrSchool :: OpticFilterColumn t SchoolId fltrSchool querySsh = singletonMap "school" . FilterColumn $ mkExactFilter (view querySsh) @@ -294,7 +294,7 @@ colCourseName resultName = Colonnade.singleton (fromSortable header) body sortCourseName :: OpticSortColumn CourseName sortCourseName queryName = singletonMap "course-name" . SortColumn $ view queryName - + ------------------------- -- Course Applications -- ------------------------- @@ -302,8 +302,8 @@ sortCourseName queryName = singletonMap "course-name" . SortColumn $ view queryN colApplicationId :: OpticColonnade CourseApplicationId colApplicationId resultId = Colonnade.singleton (fromSortable header) body where - header = Sortable Nothing (i18nCell MsgCourseApplicationId) - body = views resultId $ cell . (toWidget . toMarkup =<<) . (encrypt :: CourseApplicationId -> WidgetFor UniWorX CryptoFileNameCourseApplication) + header = Sortable Nothing $ i18nCell MsgCourseApplicationId + body = views resultId $ \aId -> cell $ toWidget . toMarkup =<< (encrypt :: CourseApplicationId -> WidgetFor UniWorX CryptoFileNameCourseApplication) aId colApplicationRatingPoints :: OpticColonnade (Maybe ExamGrade) colApplicationRatingPoints resultPoints = Colonnade.singleton (fromSortable header) body @@ -377,7 +377,7 @@ colApplicationFiles resultInfo = Colonnade.singleton (fromSortable header) body return $ CApplicationR tid ssh csh cID CAFilesR | otherwise -> mempty - + sortApplicationFiles :: OpticSortColumn Bool sortApplicationFiles queryFiles = singletonMap "has-files" . SortColumn $ view queryFiles @@ -567,7 +567,7 @@ fltrUserMatriculation queryMatriculation = singletonMap "user-matriculation" . F fltrUserMatriculationUI :: DBFilterUI fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgUserMatriculation) - + colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer @@ -781,8 +781,8 @@ fltrDegreeUI mPrev = ----------------- -- Allocations -- ----------------- - -colAllocationApplied :: OpticColonnade Int + +colAllocationApplied :: OpticColonnade Int colAllocationApplied resultApplied = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "applied") (i18nCell MsgAllocationUsersApplied) @@ -790,7 +790,7 @@ colAllocationApplied resultApplied = Colonnade.singleton (fromSortable header) b sortAllocationApplied :: forall applied. PersistField applied => OpticSortColumn applied sortAllocationApplied queryApplied = singletonMap "applied" . SortColumn $ view queryApplied - + colAllocationAssigned :: OpticColonnade Int colAllocationAssigned resultAssigned = Colonnade.singleton (fromSortable header) body where @@ -823,7 +823,7 @@ colAllocationPriority resultPriority = Colonnade.singleton (fromSortable header) where header = Sortable (Just "priority") (i18nCell MsgAllocationUsersPriority) body = views resultPriority $ \priority -> cell $(widgetFile "table/cell/allocation-priority") - + sortAllocationPriority :: OpticSortColumn (Maybe AllocationPriority) sortAllocationPriority queryPriority = singletonMap "priority" . SortColumns . views queryPriority . (. IE.veryUnsafeCoerceSqlExprValue) $ \prio -> [ SomeExprValue (prio E.->. "priorities" :: E.JSONBExpr Void) @@ -855,7 +855,7 @@ anchorColonnade :: forall h r' m a url. -> Colonnade h r' (DBCell m a) anchorColonnade = anchorColonnadeM . (return .) - + anchorColonnadeM :: forall h r' m a url. ( HasRoute UniWorX url , IsDBTable m a @@ -879,7 +879,7 @@ maybeAnchorColonnade :: forall h r' m a url. -> Colonnade h r' (DBCell m a) -> Colonnade h r' (DBCell m a) maybeAnchorColonnade = maybeAnchorColonnadeM . (hoistMaybe .) - + maybeAnchorColonnadeM :: forall h r' m a url. ( HasRoute UniWorX url , IsDBTable m a @@ -893,7 +893,7 @@ maybeAnchorColonnadeM mkUrl = imapColonnade anchorColonnade' anchorColonnade' :: r' -> DBCell m a -> DBCell m a anchorColonnade' inp (view dbCell -> (attrs, act)) = review dbCell . (attrs,) $ view (dbCell . _2) . maybeAnchorCellM (mkUrl inp) =<< act - + emptyOpticColonnade :: forall h r' focus c. Monoid c => Getting (Endo [focus]) r' focus -- ^ View on @focus@ within @r'@ that may produce any number of results @@ -914,7 +914,7 @@ emptyOpticColonnade' defC l' c where l :: Fold r' focus l = folding (toListOf l') - + Colonnade oldColonnade = c $ singular l -- This is safe (as long as we don't evaluate the `oneColonnadeEncode`s) -- because `Getter s a` is of kind @k -> *@ and can thus only be inspected @@ -922,7 +922,7 @@ emptyOpticColonnade' defC l' c -- and the definition of `OneColonnade` defaultColumn :: r' -> (r' -> c) -> c - defaultColumn x f + defaultColumn x f | has l x = f x | otherwise = defC diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 872223892..06c7666b4 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -92,7 +92,7 @@ import Colonnade.Encode hiding (row) import Text.Hamlet (hamletFile) -import Data.List (elemIndex, inits) +import Data.List (inits) import Data.Maybe (fromJust) diff --git a/src/Handler/Utils/Table/Pagination/CsvColumnExplanations.hs b/src/Handler/Utils/Table/Pagination/CsvColumnExplanations.hs index cf1c76323..6f2f22496 100644 --- a/src/Handler/Utils/Table/Pagination/CsvColumnExplanations.hs +++ b/src/Handler/Utils/Table/Pagination/CsvColumnExplanations.hs @@ -47,7 +47,7 @@ instance (GCsvColumnsExplained a, GCsvColumnsExplained b) => GCsvColumnsExplaine gCsvColumnsExplanations opts _ = Map.unionWithKey (\h f1 f2 -> error $ "Column header ‘" ++ B8.unpack h ++ "’ is produced by both ‘" ++ f1 ++ "’ and ‘" ++ f2 ++ "’") (gCsvColumnsExplanations opts (error "proxy" :: a p)) (gCsvColumnsExplanations opts (error "proxy" :: b p)) - + instance GCsvColumnsExplained a => GCsvColumnsExplained (M1 D c a) where gCsvColumnsExplanations opts _ = gCsvColumnsExplanations opts (error "proxy" :: a p) diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs index 7e8141003..b2df222ac 100644 --- a/src/Handler/Utils/Table/Pagination/Types.hs +++ b/src/Handler/Utils/Table/Pagination/Types.hs @@ -43,7 +43,7 @@ instance Headedness Sortable where instance Functor Sortable where fmap f Sortable{..} = Sortable { sortableContent = f sortableContent, .. } - + newtype SortableP s = SortableP { toSortable :: forall a. s a -> Sortable a} class Headedness s => ToSortable s where diff --git a/src/Handler/Utils/TermCandidates.hs b/src/Handler/Utils/TermCandidates.hs index 7d49f451f..5ddb8f77b 100644 --- a/src/Handler/Utils/TermCandidates.hs +++ b/src/Handler/Utils/TermCandidates.hs @@ -259,7 +259,7 @@ acceptSingletonParents = do { studySubTermsChild = StudyTermsKey' key , studySubTermsParent = StudyTermsKey' parent } - + mapM getJustEntity $ catMaybes inserted diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index be010ee94..b0aa61ce1 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -74,7 +74,7 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False asWords = filter (not . Text.null) . Text.words . Text.strip containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y - + toSql user = \case GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation') GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName' @@ -83,7 +83,7 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False go didLdap = do let retrieveUsers = E.select . E.from $ \user -> do - E.where_ . E.and $ map (toSql user) criteria + E.where_ . E.and $ map (toSql user) criteria return user users <- retrieveUsers let users' = sortBy (flip closeness) users @@ -106,11 +106,11 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False for ldapData $ upsertCampusUser UpsertCampusUser if - | x@(Entity pid _) : [] <- users' - , fromMaybe False (matchesMatriculation x) || didLdap + | [x@(Entity pid _)] <- users' + , Just True == matchesMatriculation x || didLdap -> return $ Just pid | x@(Entity pid _) : x' : _ <- users' - , fromMaybe False (matchesMatriculation x) || didLdap + , Just True == matchesMatriculation x || didLdap , GT <- x `closeness` x' -> return $ Just pid | not didLdap diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 1e1f1ea76..bc8f527b6 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -100,7 +100,7 @@ heat :: ( Real a, Real b ) -- ^ Distinguishes @full@, zero is mapped to 1, @full@ is mapped to 0 heat (realToFrac -> full) (realToFrac -> achieved) = fromRational $ cutOffCoPercent 0.3 (full^2) (achieved^2) - + invHeat :: ( Real a, Real b ) => a -> b -> Milli -- ^ Distinguishes @full@, zero is mapped to 0, @full@ is mapped to 1 @@ -110,7 +110,7 @@ coHeat :: ( Real a, Real b) => a -> b -> Milli -- ^ Distinguishes zero, zero is mapped to 1, @full@ is mapped to 0 coHeat full achieved = 1 - invCoHeat full achieved - + invCoHeat :: ( Real a, Real b) => a -> b -> Milli -- ^ Distinguishes zero, zero is mapped to 0, @full@ is mapped to 1 @@ -142,7 +142,7 @@ invDualHeat :: ( Real a, Real b, Real c ) => a -> b -> c -> Milli -- ^ Distinguishes zero, zero is mapped to 2, @optimal@ is mapped to 1, @full@ is mapped to 0 invDualHeat optimal full achieved = 2 - dualHeat optimal full achieved - + invDualCoHeat :: ( Real a, Real b, Real c ) => a -> b -> c -> Milli -- ^ Distinguishes @full@, zero is mapped to 2, @optimal@ is mapped to 1, @full@ is mapped to 0 diff --git a/src/Handler/Utils/Zip.hs b/src/Handler/Utils/Zip.hs index 0d30778c8..255d8f93b 100644 --- a/src/Handler/Utils/Zip.hs +++ b/src/Handler/Utils/Zip.hs @@ -113,7 +113,7 @@ produceZip info = C.map toZipData .| transPipe liftBase (void $ zipStream zipOpt toZipEntry File{..} = ZipEntry{..} where isDir = isNothing fileContent - + zipEntryName = encodeZipEntryName . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise $ makeValid fileTitle zipEntryTime = utcToLocalTime utc fileModified zipEntrySize = Nothing @@ -141,7 +141,7 @@ acceptFile fInfo = do fileContent <- fmap Just . runConduit $ fileSource fInfo .| foldC return File{..} - + decodeZipEntryName :: MonadThrow m => Either Text ByteString -> m FilePath -- ^ Extract the filename from a 'ZipEntry' doing decoding along the way. -- @@ -149,7 +149,7 @@ decodeZipEntryName :: MonadThrow m => Either Text ByteString -> m FilePath decodeZipEntryName = \case Left t -> return $ unpack t Right cp437 -> either throwM return $ decodeStrictByteStringExplicit CP437 cp437 - + encodeZipEntryName :: FilePath -> Either Text ByteString -- ^ Encode a filename for use in a 'ZipEntry', encodes as -- 'Data.Encoding.UTF8.UTF8' iff the given path contains non-ascii characters. diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 1e3925395..0fdedc192 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -20,6 +20,6 @@ import Settings.WellKnownFiles as Import import CryptoID as Import import Audit as Import - + import Web.ServerSession.Backend.Persistent.Memcached as Import import Web.ServerSession.Backend.Acid as Import (AcidStorage(..)) diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index d7a71dce2..846bb5c00 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -60,6 +60,7 @@ import GHC.Exts as Import (IsList) import Data.Ix as Import (Ix) import Data.Hashable as Import +import Data.List as Import (elemIndex) import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty) import Data.Text.Encoding.Error as Import(UnicodeException(..)) import Data.Semigroup as Import (Min(..), Max(..)) @@ -78,6 +79,8 @@ import Database.Persist.Sql as Import (SqlReadBackend, SqlReadT, SqlWriteT, IsSq import Ldap.Client.Pool as Import +import Control.Monad as Import (zipWithM) + import System.Random as Import (Random(..)) import Control.Monad.Random.Class as Import (MonadRandom(..)) diff --git a/src/Jobs.hs b/src/Jobs.hs index bdf6b847f..314e68679 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -492,7 +492,7 @@ jLocked jId act = do liftIO . atomically $ writeTVar hasLock True return val - unlock = whenM (liftIO . atomically $ readTVar hasLock) $ + unlock = whenM (readTVarIO hasLock) $ runDB . setSerializable $ update jId [ QueuedJobLockInstance =. Nothing , QueuedJobLockTime =. Nothing diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 2a801ff79..4a9b269a4 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -4,7 +4,7 @@ module Jobs.Crontab ( determineCrontab ) where -import Import +import Import import qualified Data.HashMap.Strict as HashMap import Jobs.Types @@ -48,7 +48,7 @@ determineCrontab = execWriterT $ do , cronRateLimit = appJobCronInterval , cronNotAfter = Right CronNotScheduled } - whenIsJust appPruneUnreferencedFiles $ \pInterval -> + whenIsJust appPruneUnreferencedFiles $ \pInterval -> tell $ HashMap.singleton (JobCtlQueue JobPruneUnreferencedFiles) Cron @@ -57,7 +57,7 @@ determineCrontab = execWriterT $ do , cronRateLimit = pInterval , cronNotAfter = Right CronNotScheduled } - + oldestInvitationMUTC <- lift $ preview (_head . _entityVal . _invitationExpiresAt . _Just) <$> selectList [InvitationExpiresAt !=. Nothing] [Asc InvitationExpiresAt, LimitTo 1] whenIsJust oldestInvitationMUTC $ \oldestInvUTC -> tell $ HashMap.singleton (JobCtlQueue JobPruneInvitations) @@ -88,7 +88,7 @@ determineCrontab = execWriterT $ do , cronNotAfter = Right CronNotScheduled } - tell . flip foldMap universeF $ \kind -> + tell . flip foldMap universeF $ \kind -> case appHealthCheckInterval kind of Just int -> HashMap.singleton (JobCtlGenerateHealthReport kind) @@ -137,7 +137,7 @@ determineCrontab = execWriterT $ do let epochInterval = syncWithin / 2 interval = appSynchroniseLdapUsersInterval - + (ldapEpoch, epochNow) = now `divMod'` epochInterval ldapInterval = epochNow `div'` interval numIntervals = floor $ epochInterval / interval @@ -168,11 +168,11 @@ determineCrontab = execWriterT $ do } | otherwise -> return () - + let sheetJobs (Entity nSheet Sheet{..}) = do - for_ (max <$> sheetVisibleFrom <*> sheetActiveFrom) $ \aFrom -> + for_ (max <$> sheetVisibleFrom <*> sheetActiveFrom) $ \aFrom -> tell $ HashMap.singleton (JobCtlQueue $ JobQueueNotification NotificationSheetActive{..}) Cron @@ -222,7 +222,7 @@ determineCrontab = execWriterT $ do , cronRepeat = CronRepeatOnChange , cronRateLimit = appNotificationRateLimit , cronNotAfter = Left appNotificationExpiration - } + } when sheetAutoDistribute $ tell $ HashMap.singleton (JobCtlQueue $ JobDistributeCorrections nSheet) @@ -239,13 +239,13 @@ determineCrontab = execWriterT $ do correctorNotifications :: Map (UserId, SheetId) (Max UTCTime) -> WriterT (Crontab JobCtl) DB () correctorNotifications = (tell .) . Map.foldMapWithKey $ \(nUser, nSheet) (Max time) -> HashMap.singleton (JobCtlQueue $ JobQueueNotification NotificationCorrectionsAssigned { nUser, nSheet } ) - Cron + Cron { cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay time , cronRepeat = CronRepeatNever , cronRateLimit = appNotificationRateLimit , cronNotAfter = Left appNotificationExpiration } - + submissionsByCorrector :: Entity Submission -> Map (UserId, SheetId) (Max UTCTime) submissionsByCorrector (Entity _ sub) | Just ratingBy <- submissionRatingBy sub @@ -261,7 +261,7 @@ determineCrontab = execWriterT $ do ) .| C.fold collateSubmissionsByCorrector Map.empty - + let examJobs (Entity nExam Exam{..}) = do newestResult <- lift . E.select . E.from $ \examResult -> do @@ -270,7 +270,7 @@ determineCrontab = execWriterT $ do whenIsJust examVisibleFrom $ \visibleFrom -> do case over (mapped . _Value) ((max `on` NTop) examFinished) newestResult of - [E.Value (NTop (Just ts))] -> + [E.Value (NTop (Just ts))] -> tell $ HashMap.singleton (JobCtlQueue $ JobQueueNotification NotificationExamResult{..}) Cron @@ -338,10 +338,10 @@ determineCrontab = execWriterT $ do , cronNotAfter = Left appNotificationExpiration } Nothing -> return () - + runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ examJobs - + let externalExamJobs nExternalExam = do newestResult <- lift . E.select . E.from $ \externalExamResult -> do diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index de85244c0..77e6337e2 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -14,7 +14,7 @@ import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlCastAs) import qualified Data.Conduit.Combinators as C import qualified Data.Conduit.List as C (mapMaybe) - + import Handler.Utils.Minio import qualified Network.Minio as Minio @@ -32,7 +32,7 @@ dispatchJobPruneSessionFiles = JobHandlerAtomic . hoist lift $ do $logInfoS "PruneSessionFiles" [st|Deleted #{n} expired session files|] - + fileReferences :: E.SqlExpr (E.Value FileContentReference) -> [E.SqlQuery ()] fileReferences (E.just -> fHash) = [ E.from $ \appFile -> E.where_ $ appFile E.^. CourseApplicationFileContent E.==. fHash @@ -47,7 +47,7 @@ fileReferences (E.just -> fHash) ] - + dispatchJobPruneUnreferencedFiles :: JobHandler UniWorX dispatchJobPruneUnreferencedFiles = JobHandlerAtomic . hoist lift $ do now <- liftIO getCurrentTime @@ -57,16 +57,16 @@ dispatchJobPruneUnreferencedFiles = JobHandlerAtomic . hoist lift $ do E.update $ \fileContent -> do let isReferenced = E.any E.exists . fileReferences $ fileContent E.^. FileContentHash now' = E.unsafeSqlCastAs "TIMESTAMP WITH TIME ZONE" $ E.val now - shouldBe = E.bool (E.just . E.maybe now' (E.min now') $ fileContent E.^. FileContentUnreferencedSince) E.nothing isReferenced + shouldBe = E.bool (E.just . E.maybe now' (E.min now') $ fileContent E.^. FileContentUnreferencedSince) E.nothing isReferenced E.set fileContent [ FileContentUnreferencedSince E.=. shouldBe ] let getCandidates = E.selectSource . E.from $ \fileContent -> do - E.where_ . E.maybe E.false (E.<. E.val (addUTCTime (-keep) now)) $ fileContent E.^. FileContentUnreferencedSince + E.where_ . E.maybe E.false (E.<. E.val (addUTCTime (-keep) now)) $ fileContent E.^. FileContentUnreferencedSince return ( fileContent E.^. FileContentHash , E.length_ $ fileContent E.^. FileContentContent ) - + Sum deleted <- runConduit $ getCandidates .| maybe (C.map id) (takeWhileTime . (/ 2)) interval @@ -90,7 +90,7 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do , Just fRef <- Crypto.digestFromByteString bs = Just (oi, fRef) extractReference _ = Nothing - + injectOrDelete :: (Minio.Object, FileContentReference) -> Handler (Sum Int64, Sum Int64) -- ^ Injected, Already existed injectOrDelete (obj, fRef) = maybeT (return mempty) $ do @@ -106,7 +106,7 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do let isReferenced = E.any E.exists $ fileReferences (E.val fRef) now' = E.unsafeSqlCastAs "TIMESTAMP WITH TIME ZONE" $ E.val now in return $ FileContent E.<# E.val fRef E.<&> E.val content E.<&> E.bool (E.just now') E.nothing isReferenced - runAppMinio . maybeT (return ()) . catchIfMaybeT minioIsDoesNotExist $ Minio.removeObject uploadBucket obj + runAppMinio . maybeT (return ()) . catchIfMaybeT minioIsDoesNotExist $ Minio.removeObject uploadBucket obj return res (Sum inj, Sum exc) <- diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs index ca07dee2b..42ad88d0f 100644 --- a/src/Jobs/Handler/HelpRequest.hs +++ b/src/Jobs/Handler/HelpRequest.hs @@ -10,7 +10,7 @@ import qualified Data.CaseInsensitive as CI import Handler.Utils import Data.Bitraversable - + dispatchJobHelpRequest :: Either (Maybe Address) UserId -> UTCTime @@ -38,10 +38,10 @@ dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer j objId <- setMailObjectIdRandom mr <- getMailMessageRender return . mr $ MsgHelpErrorYamlFilename objId - + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) whenIsJust ((,) <$> jError <*> errPartName) $ \(err, partName) -> addPart' $ do toMailPart $ toYAML err _partDisposition .= InlineDisposition partName - + diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index 29b078816..18d7d3f46 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -133,7 +133,7 @@ determineNotificationCandidates NotificationAllocationStaffRegister{..} = do E.where_ $ userSchool E.^. UserSchoolUser E.==. user E.^. UserId E.&&. userSchool E.^. UserSchoolSchool E.==. E.val allocationSchool E.&&. E.not_ (userSchool E.^. UserSchoolIsOptOut) - + E.where_ . E.not_ . E.exists . E.from $ \(course `E.InnerJoin` lecturer) -> do E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.&&. lecturer E.^. LecturerUser E.==. user E.^. UserId @@ -155,7 +155,7 @@ determineNotificationCandidates NotificationAllocationAllocation{..} = E.&&. application E.^. CourseApplicationUser E.!=. user E.^. UserId E.&&. E.not_ (E.isNothing $ application E.^. CourseApplicationRatingTime) - E.where_ . E.exists . E.from $ \application -> + E.where_ . E.exists . E.from $ \application -> E.where_ $ application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation) E.&&. application E.^. CourseApplicationCourse E.==. course E.^. CourseId E.&&. application E.^. CourseApplicationUser E.!=. user E.^. UserId @@ -167,7 +167,7 @@ determineNotificationCandidates NotificationAllocationUnratedApplications{..} = E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId - + E.where_ . E.exists . E.from $ \application -> E.where_ $ application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation) E.&&. application E.^. CourseApplicationCourse E.==. course E.^. CourseId @@ -194,7 +194,7 @@ determineNotificationCandidates NotificationAllocationOutdatedRatings{..} = E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId - + E.where_ . E.exists . E.from $ \application -> E.where_ $ application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation) E.&&. application E.^. CourseApplicationCourse E.==. course E.^. CourseId diff --git a/src/Jobs/Handler/SendNotification/Allocation.hs b/src/Jobs/Handler/SendNotification/Allocation.hs index 9932fef7c..79b40b79e 100644 --- a/src/Jobs/Handler/SendNotification/Allocation.hs +++ b/src/Jobs/Handler/SendNotification/Allocation.hs @@ -18,7 +18,7 @@ import Text.Hamlet import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E - + dispatchNotificationAllocationStaffRegister :: AllocationId -> UserId -> Handler () dispatchNotificationAllocationStaffRegister nAllocation jRecipient = userMailT jRecipient $ do @@ -87,7 +87,7 @@ dispatchNotificationAllocationUnratedApplications nAllocation jRecipient = do E.where_ $ application E.^. CourseApplicationCourse E.==. course E.^. CourseId E.&&. application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation) E.&&. E.isNothing (application E.^. CourseApplicationRatingTime) - + return ( course E.^. CourseTerm , course E.^. CourseSchool , course E.^. CourseShorthand @@ -127,7 +127,7 @@ dispatchNotificationAllocationOutdatedRatings nAllocation jRecipient = do E.where_ $ application E.^. CourseApplicationCourse E.==. course E.^. CourseId E.&&. application E.^. CourseApplicationAllocation E.==. E.val (Just nAllocation) E.&&. E.maybe E.false (E.<. application E.^. CourseApplicationTime) (application E.^. CourseApplicationRatingTime) - + return ( course E.^. CourseTerm , course E.^. CourseSchool , course E.^. CourseShorthand @@ -191,11 +191,11 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi [] | doParticipantResults -> Just [] | otherwise -> Nothing cs -> Just $ map (courseShorthand . entityVal) cs - + return (allocation, lecturerResults, participantResults) replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectAllocationResults allocationName editNotifications <- mkEditNotifications jRecipient - + addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationResults.hamlet") diff --git a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs index 720d5850c..13f66127e 100644 --- a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs +++ b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs @@ -22,7 +22,7 @@ dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do , SubmissionRatingTime ==. Nothing ] return (course, sheet, nbrSubs) - when (nbrSubs > 0) . userMailT jRecipient $ do + when (nbrSubs > 0) . userMailT jRecipient $ do replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectCorrectionsAssigned courseShorthand sheetName diff --git a/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs b/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs index 53282040e..50ba2ad51 100644 --- a/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs +++ b/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs @@ -18,7 +18,7 @@ dispatchNotificationCorrectionsNotDistributed nSheet jRecipient = do , SubmissionRatingBy ==. Nothing ] return (course, sheet, nbrSubs) - when (nbrSubs > 0) . userMailT jRecipient $ do + when (nbrSubs > 0) . userMailT jRecipient $ do replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectSubmissionsUnassigned courseShorthand sheetName MsgRenderer mr <- getMailMsgRenderer diff --git a/src/Jobs/Handler/SendNotification/CourseRegistered.hs b/src/Jobs/Handler/SendNotification/CourseRegistered.hs index 946fa5752..9bfb22ff3 100644 --- a/src/Jobs/Handler/SendNotification/CourseRegistered.hs +++ b/src/Jobs/Handler/SendNotification/CourseRegistered.hs @@ -16,8 +16,8 @@ dispatchNotificationCourseRegistered :: UserId -> CourseId -> UserId -> Handler dispatchNotificationCourseRegistered nUser nCourse jRecipient = userMailT jRecipient $ do (User{..}, Course{..}) <- liftHandler . runDB $ (,) <$> getJust nUser <*> getJust nCourse - let isSelf = nUser == jRecipient - + let isSelf = nUser == jRecipient + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ if | isSelf -> MsgMailSubjectCourseRegistered courseShorthand diff --git a/src/Jobs/Handler/SendNotification/ExamOffice.hs b/src/Jobs/Handler/SendNotification/ExamOffice.hs index fe3d8df8b..c7a6d1c37 100644 --- a/src/Jobs/Handler/SendNotification/ExamOffice.hs +++ b/src/Jobs/Handler/SendNotification/ExamOffice.hs @@ -16,7 +16,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set - + dispatchNotificationExamOfficeExamResults :: ExamId -> UserId -> Handler () dispatchNotificationExamOfficeExamResults nExam jRecipient = userMailT jRecipient $ do (Course{..}, Exam{..}) <- liftHandler . runDB $ do diff --git a/src/Jobs/Handler/SendNotification/SubmissionEdited.hs b/src/Jobs/Handler/SendNotification/SubmissionEdited.hs index 9a3ccc316..e244c02ab 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionEdited.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionEdited.hs @@ -70,7 +70,7 @@ dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient = userMai return (user, course, sheet, submission, coSubmittors) - let isSelf = nUser == jRecipient + let isSelf = nUser == jRecipient let allCoSubmittors = Text.intercalate ", " $ map (renderAddress . userAddressFrom . entityVal) coSubmittors addMailHeader "Reply-To" allCoSubmittors @@ -91,13 +91,13 @@ dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient = userMai editNotifications <- mkEditNotifications jRecipient addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/submissionUserCreated.hamlet") - + dispatchNotificationSubmissionUserDeleted :: UserId -> SheetId -> SubmissionId -> UserId -> Handler () dispatchNotificationSubmissionUserDeleted nUser nSheet nSubmission jRecipient = userMailT jRecipient $ do (User{..}, Course{..}, Sheet{..}, mSubmission, coSubmittors) <- liftHandler . runDB $ do submission <- get nSubmission - + sheet <- maybe (getJust nSheet) (belongsToJust submissionSheet) submission course <- belongsToJust sheetCourse sheet @@ -108,10 +108,10 @@ dispatchNotificationSubmissionUserDeleted nUser nSheet nSubmission jRecipient = return user user <- getJust nUser - + return (user, course, sheet, submission, coSubmittors) - let isSelf = nUser == jRecipient + let isSelf = nUser == jRecipient unless (null coSubmittors) $ do let allCoSubmittors = Text.intercalate ", " $ map (renderAddress . userAddressFrom . entityVal) coSubmittors diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs index 7770c33ad..5d4a78ec8 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionRated.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionRated.hs @@ -21,7 +21,7 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien corrector <- traverse getJust submissionRatingBy return (course, sheet, submission, corrector) - whenIsJust corrector $ \corrector' -> + whenIsJust corrector $ \corrector' -> addMailHeader "Reply-To" . renderAddress $ userAddressFrom corrector' replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand diff --git a/src/Jobs/Handler/SendNotification/Utils.hs b/src/Jobs/Handler/SendNotification/Utils.hs index e60d20cfd..a6eee899b 100644 --- a/src/Jobs/Handler/SendNotification/Utils.hs +++ b/src/Jobs/Handler/SendNotification/Utils.hs @@ -12,7 +12,7 @@ import qualified Data.HashSet as HashSet ihamletSomeMessage :: HtmlUrlI18n UniWorXMessage (Route UniWorX) -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) 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 diff --git a/src/Jobs/Handler/SendPasswordReset.hs b/src/Jobs/Handler/SendPasswordReset.hs index ce2aadd93..d5b4c75aa 100644 --- a/src/Jobs/Handler/SendPasswordReset.hs +++ b/src/Jobs/Handler/SendPasswordReset.hs @@ -18,7 +18,7 @@ dispatchJobSendPasswordReset :: UserId dispatchJobSendPasswordReset jRecipient = JobHandlerException . userMailT jRecipient $ do cID <- encrypt jRecipient User{..} <- liftHandler . runDB $ getJust jRecipient - + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI MsgMailSubjectPasswordReset diff --git a/src/Jobs/Handler/SendTestEmail.hs b/src/Jobs/Handler/SendTestEmail.hs index d396cc7c1..711322647 100644 --- a/src/Jobs/Handler/SendTestEmail.hs +++ b/src/Jobs/Handler/SendTestEmail.hs @@ -2,7 +2,7 @@ module Jobs.Handler.SendTestEmail ( dispatchJobSendTestEmail ) where -import Import +import Import import Handler.Utils.Mail import Handler.Utils.DateTime diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs index 14d5e6668..f4bdcf021 100644 --- a/src/Jobs/Handler/SynchroniseLdap.hs +++ b/src/Jobs/Handler/SynchroniseLdap.hs @@ -10,7 +10,7 @@ import qualified Data.Conduit.List as C import Auth.LDAP import Jobs.Queue - + data SynchroniseLdapException = SynchroniseLdapNoLdap @@ -40,7 +40,7 @@ dispatchJobSynchroniseLdapUser :: UserId -> JobHandler UniWorX dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do UniWorX{..} <- getYesod case appLdapPool of - Just ldapPool -> + Just ldapPool -> runDB . void . runMaybeT . handleExc $ do user@User{userIdent} <- MaybeT $ get jUser diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs index 2a96f5096..67ee78717 100644 --- a/src/Jobs/HealthReport.hs +++ b/src/Jobs/HealthReport.hs @@ -33,7 +33,7 @@ import UnliftIO.Concurrent (myThreadId) generateHealthReport :: HealthCheck -> Handler HealthReport generateHealthReport = withHealthReportMetrics . $(dispatchTH ''HealthCheck) - + dispatchHealthCheckMatchingClusterConfig :: Handler HealthReport -- ^ Can the cluster configuration be read from the database and does it match our configuration? dispatchHealthCheckMatchingClusterConfig @@ -63,7 +63,7 @@ dispatchHealthCheckMatchingClusterConfig ourSetting <- getsYesod $ fmap fst . appMemcached dbSetting <- clusterSetting @'ClusterMemcachedKey return $ maybe True ((== dbSetting) . Just) ourSetting - + clusterSetting :: forall key. ( ClusterSetting key @@ -118,7 +118,7 @@ dispatchHealthCheckSMTPConnect = fmap HealthSMTPConnect . yesodTimeout (^. _appH response@(rCode, _) <- liftIO $ SMTP.sendCommand smtpConn SMTP.NOOP case rCode of 250 -> return True - _ -> do + _ -> do $logErrorS "Mail" $ "NOOP failed: " <> tshow response return False @@ -143,7 +143,7 @@ dispatchHealthCheckWidgetMemcached = fmap HealthWidgetMemcached . yesodTimeout ( & HTTP.setRequestManager httpManager' (== content) . responseBody <$> httpLBS httpRequest _other -> return False - + dispatchHealthCheckActiveJobExecutors :: Handler HealthReport dispatchHealthCheckActiveJobExecutors = HealthActiveJobExecutors <$> do diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index 18c85be59..b5483a8c6 100644 --- a/src/Jobs/Queue.hs +++ b/src/Jobs/Queue.hs @@ -29,7 +29,7 @@ import Data.Semigroup ((<>)) import UnliftIO.Concurrent (myThreadId) import Control.Monad.Trans.Resource (register) - + data JobQueueException = JobQueuePoolEmpty | JobQueueWorkerNotFound @@ -83,9 +83,9 @@ writeJobCtlBlock = writeJobCtlBlock' writeJobCtl queueJobUnsafe :: Bool -> Job -> YesodDB UniWorX (Maybe QueuedJobId) queueJobUnsafe queuedJobWriteLastExec job = do $logInfoS "queueJob" $ tshow job - + doQueue <- fmap not . and2M (return $ jobNoQueueSame job) $ exists [ QueuedJobContent ==. toJSON job ] - + if | doQueue -> Just <$> do queuedJobCreationTime <- liftIO getCurrentTime @@ -146,5 +146,5 @@ runDBJobs' act = do forM_ jIds $ \jId -> whenM (existsKey jId) $ runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod - + return ret diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 11fe8b12e..c587bf9b8 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -174,7 +174,7 @@ data JobHandler site deriving (Generic, Typeable) makePrisms ''JobHandler - + data JobWorkerState = JobWorkerBusy @@ -215,7 +215,7 @@ showWorkerId = tshow . hashUnique . jobWorkerUnique newWorkerId :: MonadIO m => m JobWorkerId newWorkerId = JobWorkerId <$> liftIO newUnique - + data JobContext = JobContext { jobCrontab :: TVar (Crontab JobCtl) , jobConfirm :: TVar (HashMap JobCtl (NonEmpty (TMVar (Maybe SomeException)))) diff --git a/src/Ldap/Client/Pool.hs b/src/Ldap/Client/Pool.hs index d14289125..c79b7d9de 100644 --- a/src/Ldap/Client/Pool.hs +++ b/src/Ldap/Client/Pool.hs @@ -138,7 +138,7 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim delExecutor LdapExecutor{..} = do atomically . void $ tryPutTMVar ldapDestroy () wait ldapAsync - withRunInIO $ \runInIO -> + withRunInIO $ \runInIO -> createPool (runInIO mkExecutor) delExecutor stripes timeoutConn limit where withTimeout :: forall m' a. (MonadUnliftIO m', MonadThrow m') => m' a -> m' a diff --git a/src/Mail.hs b/src/Mail.hs index 36ae4146d..a446040ff 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -111,7 +111,7 @@ import Control.Monad.Trans.Maybe (MaybeT(..)) import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI - + import Control.Monad.Random (MonadRandom(..)) import qualified Crypto.Saltine.Class as Saltine (IsEncoding(..)) import qualified Data.ByteArray as ByteArray (convert) @@ -227,11 +227,11 @@ data MailException = MailNotAvailable deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Exception MailException - + class Yesod site => YesodMail site where defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address - defaultFromAddress = (Address Nothing . ("yesod@" <>) . pack) <$> liftIO getHostName + defaultFromAddress = Address Nothing . ("yesod@" <>) . pack <$> liftIO getHostName mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text mailObjectIdDomain = pack <$> liftIO getHostName @@ -464,7 +464,7 @@ replaceMailHeaderI :: ( RenderMessage site msg , MonadHeader m ) => MailHeader -> msg -> m () replaceMailHeaderI header msg = removeMailHeader header >> addMailHeaderI header msg - + addMailHeaderI :: ( RenderMessage site msg , MonadMail m , HandlerSite m ~ site @@ -523,7 +523,7 @@ setDate time = do rfc822zone tz' | tz' `elem` rfc822zones = tz' | otherwise = tz' { timeZoneName = "" } - rfc822zones = + rfc822zones = [ TimeZone 0 False "UT" , TimeZone 0 False "GMT" , TimeZone (-5 * 60) False "EST" diff --git a/src/Model.hs b/src/Model.hs index fcd41546b..301846972 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -140,7 +140,7 @@ instance HasFileReference SheetFile where fileReferenceTitleField = SheetFileTitle fileReferenceContentField = SheetFileContent fileReferenceModifiedField = SheetFileModified - + instance HasFileReference SubmissionFile where data FileReferenceResidual SubmissionFile = SubmissionFileResidual { submissionFileResidualSubmission :: SubmissionId @@ -233,4 +233,4 @@ instance HasFileReference MaterialFile where fileReferenceTitleField = MaterialFileTitle fileReferenceContentField = MaterialFileContent fileReferenceModifiedField = MaterialFileModified - + diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 6b4c67ee8..1bc6a8e62 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -55,7 +55,7 @@ import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorag -- -- Doing so creates sort of parallel commit history tracking changes to the database schema - + share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"] [persistLowerCase| AppliedMigration json @@ -90,11 +90,11 @@ migrateAll = do $logInfoS "Migration" [st|#{tshow appliedMigrationFrom} -> #{tshow appliedMigrationTo}|] appliedMigrationTime <- liftIO getCurrentTime _ <- migration - insert AppliedMigration{..} + insert AppliedMigration{..} -- Map.foldlWithKey traverses migrations in ascending order of AppliedMigrationKey $logDebugS "Migration" "Apply missing migrations" - Map.foldlWithKey doCustomMigration (return ()) missingMigrations - + Map.foldlWithKey doCustomMigration (return ()) missingMigrations + $logDebugS "Migration" "Persistent automatic migration" mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAll' @@ -105,20 +105,20 @@ requiresMigration :: forall m. => ReaderT SqlBackend m Bool requiresMigration = mapReaderT (exceptT return return) $ do initial <- either id (map snd) <$> parseMigration initialMigration - when (not $ null initial) $ do + unless (null initial) $ do $logInfoS "Migration" $ intercalate "; " initial throwError True customs <- mapReaderT lift $ getMissingMigrations @_ @m - when (not $ Map.null customs) $ do + unless (Map.null customs) $ do $logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs throwError True - + automatic <- either id (map snd) <$> parseMigration migrateAll' - when (not $ null automatic) $ do + unless (null automatic) $ do $logInfoS "Migration" $ intercalate "; " automatic throwError True - + return False initialMigration :: Migration @@ -188,7 +188,7 @@ customMigrations = Map.fromListWith (>>) other -> error $ "Could not parse theme: " <> show other ) , ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|] - , whenM (tableExists "sheet") $ -- Better JSON encoding + , whenM (tableExists "sheet") -- Better JSON encoding [executeQQ| ALTER TABLE "sheet" ALTER COLUMN "type" TYPE jsonb USING "type"::jsonb; ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE jsonb USING "grouping"::jsonb; @@ -265,13 +265,13 @@ customMigrations = Map.fromListWith (>>) _other -> error "Empty userDisplayName found" ) , ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|] - , whenM (tableExists "sheet") $ + , whenM (tableExists "sheet") [executeQQ| ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" jsonb DEFAULT '{ "tag": "Upload", "unpackZips": true }'; |] ) , ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|] - , whenM (columnExists "user" "plugin") $ + , whenM (columnExists "user" "plugin") -- <> is standard sql for /= [executeQQ| DELETE FROM "user" WHERE "plugin" <> 'LDAP'; @@ -280,7 +280,7 @@ customMigrations = Map.fromListWith (>>) |] ) , ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|] - , whenM (tableExists "user") $ + , whenM (tableExists "user") [executeQQ| ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" jsonb NOT NULL DEFAULT '[]'; |] @@ -288,16 +288,16 @@ customMigrations = Map.fromListWith (>>) , ( AppliedMigrationKey [migrationVersion|5.0.0|] [version|6.0.0|] , whenM (tableExists "sheet") $ do sheets <- [sqlQQ| SELECT "id", "type" FROM "sheet"; |] - forM_ sheets $ \(sid, Single lsty) -> update sid [SheetType =. Legacy.sheetType lsty] + forM_ sheets $ \(sid, Single lsty) -> update sid [SheetType =. Legacy.sheetType lsty] ) , ( AppliedMigrationKey [migrationVersion|6.0.0|] [version|7.0.0|] - , whenM (tableExists "cluster_config") $ + , whenM (tableExists "cluster_config") [executeQQ| UPDATE "cluster_config" SET "setting" = 'secret-box-key' WHERE "setting" = 'error-message-key'; |] ) , ( AppliedMigrationKey [migrationVersion|7.0.0|] [version|8.0.0|] - , whenM (tableExists "sheet") $ + , whenM (tableExists "sheet") [executeQQ| UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', "type"->'') WHERE jsonb_exists("type", ''); UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points')) WHERE ("type"->'grading'->'type') = '"points"' AND jsonb_exists("type"->'grading', 'points'); @@ -315,10 +315,10 @@ customMigrations = Map.fromListWith (>>) ) , ( AppliedMigrationKey [migrationVersion|9.0.0|] [version|10.0.0|] , do - whenM (columnExists "study_degree" "shorthand") $ [executeQQ| UPDATE "study_degree" SET "shorthand" = NULL WHERE "shorthand" = '' |] - whenM (columnExists "study_degree" "name") $ [executeQQ| UPDATE "study_degree" SET "name" = NULL WHERE "shorthand" = '' |] - whenM (columnExists "study_terms" "shorthand") $ [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |] - whenM (columnExists "study_terms" "name") $ [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |] + whenM (columnExists "study_degree" "shorthand") [executeQQ| UPDATE "study_degree" SET "shorthand" = NULL WHERE "shorthand" = '' |] + whenM (columnExists "study_degree" "name") [executeQQ| UPDATE "study_degree" SET "name" = NULL WHERE "shorthand" = '' |] + whenM (columnExists "study_terms" "shorthand") [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |] + whenM (columnExists "study_terms" "name") [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |] ) , ( AppliedMigrationKey [migrationVersion|10.0.0|] [version|11.0.0|] , whenM ((&&) <$> columnExists "sheet" "upload_mode" <*> columnExists "sheet" "submission_mode") $ do @@ -388,7 +388,7 @@ customMigrations = Map.fromListWith (>>) ALTER TABLE transaction_log ADD COLUMN "initiator_id" bigint DEFAULT null; |] - whenM (tableExists "user") $ + whenM (tableExists "user") [executeQQ| UPDATE transaction_log SET initiator_id = "user".id FROM "user" WHERE transaction_log.initiator = "user".ident; |] @@ -420,7 +420,7 @@ customMigrations = Map.fromListWith (>>) eid <- MaybeT . getKeyBy $ UniqueExam cid examn uid <- MaybeT . getKeyBy $ UniqueAuthentication uident return $ TransactionExamRegister eid uid - whenIsJust newT $ \newT' -> + whenIsJust newT $ \newT' -> update lid [ TransactionLogInfo =. toJSON newT' ] updateTransactionInfo _ = return () runConduit $ getLogEntries .| C.mapM_ updateTransactionInfo @@ -441,7 +441,7 @@ customMigrations = Map.fromListWith (>>) [executeQQ| UPDATE "course" SET ("applications_required", "applications_instructions", "applications_text", "applications_files", "applications_ratings_visible") = (#{appRequired}, #{applicationsInstructions}, #{applicationsText}, #{applicationsFiles}, #{applicationsRatingsVisible}) WHERE "id" = #{cid}; |] - + [executeQQ| ALTER TABLE "allocation_course" DROP COLUMN "instructions", DROP COLUMN "application_text", DROP COLUMN "application_files", DROP COLUMN "ratings_visible"; |] @@ -537,7 +537,7 @@ customMigrations = Map.fromListWith (>>) . snd ) & map fst - forM_ (zip [_ExamPartNumber' # 1..] partsSorted) $ \(num :: ExamPartNumber, pId) -> + forM_ (zip [_ExamPartNumber' # 1..] partsSorted) $ \(num :: ExamPartNumber, pId) -> [executeQQ| UPDATE "exam_part" SET "number" = #{num} WHERE "id" = #{pId}; |] @@ -572,13 +572,13 @@ customMigrations = Map.fromListWith (>>) |] ) , ( AppliedMigrationKey [migrationVersion|22.0.0|] [version|23.0.0|] - , whenM (tableExists "exam") $ + , whenM (tableExists "exam") [executeQQ| UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points'; |] ) , ( AppliedMigrationKey [migrationVersion|23.0.0|] [version|24.0.0|] - , whenM (tableExists "course_favourite") $ + , whenM (tableExists "course_favourite") [executeQQ| ALTER TABLE "course_favourite" RENAME COLUMN "time" TO "last_visit"; ALTER TABLE "course_favourite" ADD COLUMN "reason" jsonb DEFAULT '"visited"'::jsonb; @@ -596,7 +596,7 @@ customMigrations = Map.fromListWith (>>) _other -> error "Cannot reconstruct course_participant.allocated" ) , ( AppliedMigrationKey [migrationVersion|25.0.0|] [version|26.0.0|] - , whenM (tableExists "allocation") $ + , whenM (tableExists "allocation") [executeQQ| CREATE TABLE "allocation_matching" ("id" SERIAL8 PRIMARY KEY UNIQUE, "allocation" INT8 NOT NULL, "fingerprint" BYTEA NOT NULL, "log" INT8 NOT NULL); INSERT INTO "allocation_matching" ("allocation", "fingerprint", "log") (select "id" as "allocation", "fingerprint", "matching_log" as "log" from "allocation" where not ("matching_log" is null) and not ("fingerprint" is null)); @@ -605,7 +605,7 @@ customMigrations = Map.fromListWith (>>) |] ) , ( AppliedMigrationKey [migrationVersion|26.0.0|] [version|27.0.0|] - , whenM (tableExists "user") $ + , whenM (tableExists "user") [executeQQ| ALTER TABLE "user" ADD COLUMN "languages" jsonb; UPDATE "user" SET "languages" = "mail_languages" where "mail_languages" <> '[]'; @@ -617,7 +617,7 @@ customMigrations = Map.fromListWith (>>) tableDropEmpty "exam_part_corrector" ) , ( AppliedMigrationKey [migrationVersion|28.0.0|] [version|29.0.0|] - , whenM (tableExists "study_features") $ + , whenM (tableExists "study_features") [executeQQ| ALTER TABLE "study_features" ADD COLUMN "super_field" bigint; UPDATE "study_features" SET "super_field" = "field", "field" = "sub_field" WHERE NOT ("sub_field" IS NULL); @@ -625,7 +625,7 @@ customMigrations = Map.fromListWith (>>) |] ) , ( AppliedMigrationKey [migrationVersion|29.0.0|] [version|30.0.0|] - , whenM (tableExists "exam") $ + , whenM (tableExists "exam") [executeQQ| UPDATE "exam" SET "occurrence_rule" = #{ExamRoomManual} WHERE "occurrence_rule" IS NULL; ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" SET NOT NULL; @@ -640,7 +640,7 @@ customMigrations = Map.fromListWith (>>) in [executeQQ|UPDATE exam_result SET result = #{res'} WHERE id = #{resId};|] ) , ( AppliedMigrationKey [migrationVersion|31.0.0|] [version|32.0.0|] - , whenM (tableExists "exam") $ + , whenM (tableExists "exam") [executeQQ| ALTER TABLE "exam" ADD COLUMN "grading_mode" character varying; UPDATE "exam" SET "grading_mode" = 'grades' WHERE "show_grades"; @@ -650,7 +650,7 @@ customMigrations = Map.fromListWith (>>) |] ) , ( AppliedMigrationKey [migrationVersion|32.0.0|] [version|33.0.0|] - , whenM (tableExists "external_exam") $ + , whenM (tableExists "external_exam") [executeQQ| ALTER TABLE "external_exam" ADD COLUMN "grading_mode" character varying; UPDATE "external_exam" SET "grading_mode" = 'grades' WHERE "show_grades"; @@ -716,7 +716,7 @@ customMigrations = Map.fromListWith (>>) (fromPersistValue . unSingle -> Right (fileReferenceTitle' :: FilePath), fromPersistValue . unSingle -> Right fileReferenceModified, fromPersistValue . unSingle -> Right fileReferenceContent) -> do let fileRef fileReferenceTitle = _FileReference # (FileReference{..}, residual) candidateTitles = fileReferenceTitle' : [ fName <.> ("old-" <> show n) <.> ext | n <- [1..1000] ] - where (fName, ext) = splitExtension fileReferenceTitle' + where (fName, ext) = splitExtension fileReferenceTitle' validTitles <- dropWhileM (fmap (is _Just) . checkUnique . fileRef) candidateTitles case validTitles of fTitle : _ -> doUpdate . Entity fRefKey $ fileRef fTitle @@ -849,7 +849,7 @@ customMigrations = Map.fromListWith (>>) ALTER TABLE "allocation_matching" RENAME COLUMN "log_ref" TO "log"; |] - whenM (tableExists "session_file") $ + whenM (tableExists "session_file") [executeQQ| ALTER TABLE "session_file" ADD COLUMN "content" BYTEA; UPDATE "session_file" SET "content" = (SELECT "hash" FROM "file" WHERE "file".id = "session_file"."file"); @@ -920,4 +920,4 @@ columnExists table column = do case haveColumn :: [Single PersistValue] of [_] -> return True _other -> return False - + diff --git a/src/Model/Migration/Types.hs b/src/Model/Migration/Types.hs index 23f4e6a17..019701659 100644 --- a/src/Model/Migration/Types.hs +++ b/src/Model/Migration/Types.hs @@ -55,7 +55,7 @@ deriveJSON defaultOptions ''SheetType Current.derivePersistFieldJSON ''SheetType - + data Transaction = TransactionTermEdit { transactionTerm :: Current.TermIdentifier @@ -75,7 +75,7 @@ data Transaction , transactionUser :: Current.UserIdent } deriving (Eq, Ord, Read, Show, Generic, Typeable) - + deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 , fieldLabelModifier = camelToPathPiece' 1 diff --git a/src/Model/Migration/Version.hs b/src/Model/Migration/Version.hs index 35c799a10..c5239e4bb 100644 --- a/src/Model/Migration/Version.hs +++ b/src/Model/Migration/Version.hs @@ -24,7 +24,7 @@ import Data.Data (Data) deriving instance Lift Version - + data MigrationVersion = InitialVersion | MigrationVersion Version deriving (Eq, Ord, Show, Read, Generic, Typeable, Data, Lift) diff --git a/src/Model/Tokens/Bearer.hs b/src/Model/Tokens/Bearer.hs index c2231f0f9..d8e3cd901 100644 --- a/src/Model/Tokens/Bearer.hs +++ b/src/Model/Tokens/Bearer.hs @@ -10,7 +10,7 @@ module Model.Tokens.Bearer import ClassyPrelude.Yesod import Yesod.Core.Instances () - + import Model import Model.Tokens.Lens import Utils (assertM', foldMapM) diff --git a/src/Model/Tokens/Lens.hs b/src/Model/Tokens/Lens.hs index 2f2a95571..cb813f769 100644 --- a/src/Model/Tokens/Lens.hs +++ b/src/Model/Tokens/Lens.hs @@ -10,7 +10,7 @@ class HasTokenIdentifier s a | s -> a where class HasTokenIssuedBy s a | s -> a where _tokenIssuedBy :: Lens' s a - + class HasTokenIssuedFor s a | s -> a where _tokenIssuedFor :: Lens' s a diff --git a/src/Model/Tokens/Session.hs b/src/Model/Tokens/Session.hs index 4f0180491..2a5990eaf 100644 --- a/src/Model/Tokens/Session.hs +++ b/src/Model/Tokens/Session.hs @@ -8,9 +8,9 @@ import ClassyPrelude.Yesod import Model.Tokens.Lens import Model import Utils.Lens - + import Web.ServerSession.Core - + import Jose.Jwt (IntDate(..)) import qualified Jose.Jwt as Jose @@ -70,7 +70,7 @@ instance FromJSON (SessionToken sess) where fromPathPiece aud let sessionExpiresAt = unIntDate <$> jwtExp sessionStartsAt = unIntDate <$> jwtNbf - + return SessionToken{..} where parseMaybe errId = maybe (fail $ "Could not parse " <> errId) return diff --git a/src/Model/Types/Allocation.hs b/src/Model/Types/Allocation.hs index f03b5ce69..afa9461d4 100644 --- a/src/Model/Types/Allocation.hs +++ b/src/Model/Types/Allocation.hs @@ -16,7 +16,7 @@ import qualified Data.Csv as Csv import qualified Data.Vector as Vector import qualified Data.Map.Strict as Map - + import Crypto.Hash (SHAKE128) import qualified Database.Esqueleto as E diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index 8577a86fa..ceb97f2a2 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -11,7 +11,7 @@ module Model.Types.Common import Import.NoModel import qualified Yesod.Auth.Util.PasswordStore as PWStore - + type Count = Sum Integer type Points = Centi diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 25cb813a5..6dbc7122e 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -59,6 +59,8 @@ import qualified Data.Foldable import Data.Aeson (genericToJSON, genericParseJSON) +{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} + data ExamResult' res = ExamAttended { examResult :: res } | ExamNoShow @@ -97,7 +99,7 @@ instance Applicative ExamResult' where instance Foldable ExamResult' where foldMap = foldMapOf _examResult - + instance Traversable ExamResult' where traverse = _examResult @@ -170,7 +172,7 @@ derivePersistFieldJSON ''ExamOccurrenceRule makePrisms ''ExamOccurrenceRule examOccurrenceRuleAutomatic :: ExamOccurrenceRule -> Bool -examOccurrenceRuleAutomatic x = or $ map ($ x) +examOccurrenceRuleAutomatic x = any ($ x) [ is _ExamRoomSurname , is _ExamRoomMatriculation , is _ExamRoomRandom @@ -388,7 +390,7 @@ _ExamPartNumber' = prism (ExamPartNumber . fromNum) (first ExamPartNumber . toNu fromNum (toInteger -> n) | n < 0 = [Left "-", Right . fromInteger $ abs n] | otherwise = [Right $ fromInteger n] - + toNum fs | Just ns <- mapM (preview _Right) fs = case ns of @@ -401,7 +403,7 @@ _ExamPartNumber' = prism (ExamPartNumber . fromNum) (first ExamPartNumber . toNu instance Show ExamPartNumber where showsPrec p = showsPrec p . CI.original . view _ExamPartNumber instance Read ExamPartNumber where - readPrec = review _ExamPartNumber . CI.mk <$> readPrec + readPrec = review _ExamPartNumber . CI.mk <$> readPrec instance PersistField ExamPartNumber where toPersistValue = toPersistValue . view _ExamPartNumber diff --git a/src/Model/Types/Health.hs b/src/Model/Types/Health.hs index af2a14147..0dc4af620 100644 --- a/src/Model/Types/Health.hs +++ b/src/Model/Types/Health.hs @@ -27,7 +27,7 @@ deriveJSON defaultOptions } ''HealthCheck nullaryPathPiece ''HealthCheck $ camelToPathPiece' 2 pathPieceJSONKey ''HealthCheck - + data HealthReport = HealthMatchingClusterConfig { healthMatchingClusterConfig :: Bool } -- ^ Is the database-stored configuration we're running under still up to date? @@ -87,7 +87,7 @@ healthReportStatus = \case HealthHTTPReachable (Just False) -> HealthFailure HealthLDAPAdmins (Just prop ) | prop <= 0 -> HealthFailure - HealthSMTPConnect (Just False) -> HealthFailure + HealthSMTPConnect (Just False) -> HealthFailure HealthWidgetMemcached (Just False) -> HealthFailure -- TODO: investigate this failure mode; do we just handle it gracefully? HealthActiveJobExecutors (Just prop ) | prop <= 0 -> HealthFailure diff --git a/src/Model/Types/Languages.hs b/src/Model/Types/Languages.hs index 8ed789fb6..0f5568720 100644 --- a/src/Model/Types/Languages.hs +++ b/src/Model/Types/Languages.hs @@ -10,7 +10,7 @@ import GHC.Exts (IsList) import Model.Types.TH.JSON import Control.Lens.TH (makeWrapped) - + newtype Languages = Languages [Lang] deriving (Eq, Ord, Show, Read, Generic, Typeable) diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index 6e33c53dc..bc8e1c23d 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -73,7 +73,7 @@ deriveFinite ''Quoting nullaryPathPiece ''Quoting $ \q -> if | q == "QuoteNone" -> "never" | otherwise -> camelToPathPiece' 1 q - + data CsvOptions = CsvOptions { csvFormat :: CsvFormatOptions @@ -156,7 +156,7 @@ instance FromJSON CsvOptions where csvFormat <- o JSON..:? "format" JSON..!= csvFormat def csvTimestamp <- o JSON..:? "timestamp" JSON..!= csvTimestamp def return CsvOptions{..} - + instance ToJSON CsvFormatOptions where toJSON CsvFormatOptions{..} = JSON.object [ "delimiter" JSON..= fromEnum csvDelimiter @@ -171,7 +171,7 @@ instance FromJSON CsvFormatOptions where csvQuoting <- o JSON..:? "quoting" JSON..!= csvQuoting def csvEncoding <- o JSON..:? "encoding" JSON..!= csvEncoding def return CsvFormatOptions{..} - + derivePersistFieldJSON ''CsvOptions nullaryPathPiece ''CsvPreset $ camelToPathPiece' 2 diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 0cd47cc69..8507da7d0 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -152,7 +152,7 @@ instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF) instance (Ord a, PathPiece a) => PathPiece (PredDNF a) where - toPathPiece = Text.unwords . map (Text.intercalate "AND") . map (map toPathPiece . otoList) . otoList . dnfTerms + toPathPiece = Text.unwords . map (Text.intercalate "AND" . map toPathPiece . otoList) . otoList . dnfTerms fromPathPiece = fmap (PredDNF . Set.fromList) . mapM (fromNullable <=< foldMapM (fmap Set.singleton . fromPathPiece) . Text.splitOn "AND") . concatMap (Text.splitOn "OR") . Text.words type AuthLiteral = PredLiteral AuthTag diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index e596d64c6..49bf2d76c 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -19,7 +19,7 @@ import qualified Data.Map as Map import Text.Blaze (Markup) import Data.Maybe (fromJust) - + import qualified Data.Csv as Csv diff --git a/src/Model/Types/Submission.hs b/src/Model/Types/Submission.hs index b8ace9549..162952d2e 100644 --- a/src/Model/Types/Submission.hs +++ b/src/Model/Types/Submission.hs @@ -23,10 +23,10 @@ import qualified Data.Text as Text import qualified Data.Set as Set -import Data.List (elemIndex, genericIndex) +import Data.List (genericIndex) import Data.Bits import Data.Text.Metrics (damerauLevenshtein) - + ------------------------- -- Submission Download -- ------------------------- @@ -50,7 +50,7 @@ isUpdateSubmissionFileType True = SubmissionCorrected --------------------------- -- Submission Pseudonyms -- --------------------------- - + type PseudonymWord = CI Text newtype Pseudonym = Pseudonym Word24 @@ -137,7 +137,7 @@ _PseudonymText = prism' tToWords tFromWords . _PseudonymWords pseudonymWords :: Fold Text PseudonymWord pseudonymWords = folding - $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist + $ \(CI.mk -> input) -> maybe [] (map (view _2)) . listToMaybe . groupBy ((==) `on` view _1) . sortOn (view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist where distance = damerauLevenshtein `on` CI.foldedCase -- | Arbitrary cutoff point, for reference: ispell cuts off at 1 diff --git a/src/Model/Types/TH/JSON.hs b/src/Model/Types/TH/JSON.hs index 34a752350..c1ca6a88a 100644 --- a/src/Model/Types/TH/JSON.hs +++ b/src/Model/Types/TH/JSON.hs @@ -64,4 +64,4 @@ predNFAesonOptions = defaultOptions , sumEncoding = ObjectWithSingleField , tagSingleConstructors = True } - + diff --git a/src/Network/Mail/Mime/Instances.hs b/src/Network/Mail/Mime/Instances.hs index 201442aee..ca2e73f91 100644 --- a/src/Network/Mail/Mime/Instances.hs +++ b/src/Network/Mail/Mime/Instances.hs @@ -15,7 +15,7 @@ import Utils.PathPiece import Utils (assertM) import qualified Data.Csv as Csv - + deriving instance Read Address deriving instance Ord Address diff --git a/src/Network/Mime/TH.hs b/src/Network/Mime/TH.hs index e90033904..da941bfc9 100644 --- a/src/Network/Mime/TH.hs +++ b/src/Network/Mime/TH.hs @@ -21,7 +21,7 @@ import Instances.TH.Lift () mimeMapFile, mimeSetFile :: FilePath -> ExpQ mimeMapFile file = do qAddDependentFile file - + mappings <- runIO $ filter (not . isComment) . Text.lines <$> Text.readFile file let coMappings :: [(Extension, MimeType)] @@ -38,7 +38,7 @@ mimeMapFile file = do lift mimeMap mimeSetFile file = do qAddDependentFile file - + ls <- runIO $ filter (not . isComment) . Text.lines <$> Text.readFile file let mimeSet :: Set MimeType diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs index bc72857ea..ae619dd73 100644 --- a/src/Settings/Cluster.hs +++ b/src/Settings/Cluster.hs @@ -57,7 +57,7 @@ instance ToHttpApiData ClusterSettingsKey where instance FromHttpApiData ClusterSettingsKey where parseUrlPiece = maybe (Left "Could not parse url piece") Right . fromPathPiece - + class (ToJSON (ClusterSettingValue key), FromJSON (ClusterSettingValue key)) => ClusterSetting (key :: ClusterSettingsKey) where type ClusterSettingValue key :: * initClusterSetting :: forall m p. MonadIO m => p key -> m (ClusterSettingValue key) @@ -86,7 +86,7 @@ instance ClusterSetting 'ClusterServerSessionKey where type ClusterSettingValue 'ClusterServerSessionKey = AEAD.Key initClusterSetting _ = liftIO AEAD.newKey knownClusterSetting _ = ClusterServerSessionKey - + instance ToJSON AEAD.Key where toJSON = Aeson.String . decodeUtf8 . Base64.encode . Saltine.encode diff --git a/src/Settings/Log.hs b/src/Settings/Log.hs index 112519e41..57742ad0b 100644 --- a/src/Settings/Log.hs +++ b/src/Settings/Log.hs @@ -31,12 +31,12 @@ instance Hashable LogSettings instance NFData LogSettings instance Hashable LogDestination instance NFData LogDestination - + deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 , sumEncoding = UntaggedValue } ''LogLevel - + deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 , fieldLabelModifier = camelToPathPiece' 2 diff --git a/src/Settings/StaticFiles/Generator.hs b/src/Settings/StaticFiles/Generator.hs index 47c04090c..f7fb5daf1 100644 --- a/src/Settings/StaticFiles/Generator.hs +++ b/src/Settings/StaticFiles/Generator.hs @@ -36,7 +36,7 @@ staticGenerator staticDir = do where toEntries :: FilePath -- ^ Absolute path -> IO [Entry] - toEntries loc = compile (mimeLookup $ pack loc) (makeRelative staticDir loc) loc + toEntries loc = compile (mimeLookup $ pack loc) (makeRelative staticDir loc) loc compile :: MimeType -> Location -- ^ Relative location diff --git a/src/Settings/StaticFiles/Webpack.hs b/src/Settings/StaticFiles/Webpack.hs index 3fcd6c224..999f959ab 100644 --- a/src/Settings/StaticFiles/Webpack.hs +++ b/src/Settings/StaticFiles/Webpack.hs @@ -54,11 +54,11 @@ mkWebpackEntrypoints manifest mkGen stDir = do , "” has no haskellName" ] Just n -> tell $ pure (n, ebMimeType entry) - + let entryName = mkName $ "webpackEntrypoint_" <> entrypoint widgetName = mkName $ "webpackLinks_" <> entrypoint - staticR <- newName "staticR" + staticR <- newName "staticR" sequence [ sigD entryName [t|[(Route EmbeddedStatic, MimeType)]|] , funD entryName @@ -89,4 +89,4 @@ mkWebpackEntrypoints manifest mkGen stDir = do Left exc -> throwM exc Right (ws, res') -> res' <$ mapM_ (\w -> reportWarning $ "Warning while parsing webpack manifest: " <> show w) ws - + diff --git a/src/Settings/WellKnownFiles.hs b/src/Settings/WellKnownFiles.hs index 91b4dfd9a..fcb207c7b 100644 --- a/src/Settings/WellKnownFiles.hs +++ b/src/Settings/WellKnownFiles.hs @@ -5,7 +5,7 @@ module Settings.WellKnownFiles ) where import Settings.WellKnownFiles.TH - + import Settings (appWellKnownDir, appWellKnownLinkFile, compileTimeAppSettings) mkWellKnown "de-de-formal" (appWellKnownDir compileTimeAppSettings) (appWellKnownLinkFile compileTimeAppSettings) diff --git a/src/Settings/WellKnownFiles/TH.hs b/src/Settings/WellKnownFiles/TH.hs index e88a25755..a8eacb92c 100644 --- a/src/Settings/WellKnownFiles/TH.hs +++ b/src/Settings/WellKnownFiles/TH.hs @@ -4,7 +4,7 @@ module Settings.WellKnownFiles.TH import ClassyPrelude.Yesod import Utils - + import Language.Haskell.TH import Language.Haskell.TH.Syntax hiding (Lift(..)) import qualified Language.Haskell.TH.Syntax as TH (Lift(..)) @@ -107,7 +107,7 @@ mkWellKnown defLang wellKnownBase wellKnownLinks = do -> return $ defLang :| Set.toList languages' | otherwise -> fail "default language is missing in wellKnownBase" - + fVar <- newName "f" hVar <- newName "h" @@ -121,7 +121,7 @@ mkWellKnown defLang wellKnownBase wellKnownLinks = do wellKnownFileName = dataD (cxt []) - nWellKnownFileName + nWellKnownFileName [] Nothing [ normalC (mkName $ fNameManip fName) [] @@ -142,7 +142,7 @@ mkWellKnown defLang wellKnownBase wellKnownLinks = do [ clause [conP (mkName $ fNameManip fName) []] (normalB . TH.lift . map Text.pack $ splitDirectories fName) [] | fName <- Set.toList fileNames ] - , funD 'fromPathMultiPiece $ + , funD 'fromPathMultiPiece [ clause [] (normalB [e|flip HashMap.lookup $(varE nwellKnownFileNames)|]) [] ] ] @@ -157,7 +157,7 @@ mkWellKnown defLang wellKnownBase wellKnownLinks = do getWellKnownR = funD ngetWellKnownR [ clause [varP fVar] (normalB [e|$(varE hVar) =<< selectLanguage fLanguages|]) - [ funD hVar $ + [ funD hVar $ [ clause [varP lVar] (guardedB [ (,) <$> normalG [e|HashSet.member ($(varE lVar), $(varE fVar)) $ HashSet.fromList $(listE [ tupE [TH.lift l, conE . mkName $ fNameManip fName] | (l, fName) <- Set.toList xs ])|] <*> [e|TypedContent mime (toContent fContent) <$ setEtag $(TH.lift $ hashToText (mime, fContent))|] @@ -174,7 +174,7 @@ mkWellKnown defLang wellKnownBase wellKnownLinks = do nwellKnownHtmlLinks [ clause [] (normalB [e|toWidgetHead . preEscapedToHtml . $(varE hVar) =<< selectLanguage lLanguages|]) [ sigD hVar [t|Text -> Text|] - , funD hVar $ + , funD hVar $ [ clause [varP lVar] (guardedB [ (,) <$> normalG [|$(varE lVar) == lang|] <*> TH.lift (Text.filter (`notElem` ['\r', '\n']) $ Text.decodeUtf8 c) diff --git a/src/UnliftIO/Async/Utils.hs b/src/UnliftIO/Async/Utils.hs index 4b775e807..3e0184997 100644 --- a/src/UnliftIO/Async/Utils.hs +++ b/src/UnliftIO/Async/Utils.hs @@ -21,7 +21,7 @@ allocateAsync act = withRunInIO $ \run -> run . fmap (view _2) . flip allocate A allocateLinkedAsync :: forall m a. (MonadUnliftIO m, MonadResource m) => m a -> m (Async a) allocateLinkedAsync = uncurry (<$) . (id &&& UnliftIO.link) <=< allocateAsync - + allocateAsyncWithUnmask :: forall m a. ( MonadUnliftIO m, MonadResource m ) => ((forall b. m b -> m b) -> m a) -> m (Async a) @@ -30,7 +30,7 @@ allocateAsyncWithUnmask act = withRunInIO $ \run -> run . fmap (view _2) . flip allocateLinkedAsyncWithUnmask :: forall m a. (MonadUnliftIO m, MonadResource m) => ((forall b. m b -> m b) -> m a) -> m (Async a) allocateLinkedAsyncWithUnmask act = uncurry (<$) . (id &&& UnliftIO.link) =<< allocateAsyncWithUnmask act - + allocateAsyncMasked :: forall m a. ( MonadUnliftIO m, MonadResource m ) => m a -> m (Async a) diff --git a/src/Utils.hs b/src/Utils.hs index 0b5670ad7..4a6d66df4 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -51,6 +51,7 @@ import Control.Lens as Utils (none) import Control.Lens.Extras (is) import Data.Set.Lens +import Control.Monad (zipWithM) import Control.Arrow as Utils ((>>>)) import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT) import Control.Monad.Except (MonadError(..)) @@ -149,7 +150,7 @@ maybeAttribute :: Text -> (a -> Text) -> Maybe a -> [(Text,Text)] maybeAttribute _ _ Nothing = [] maybeAttribute a c (Just v) = [(a,c v)] - + newtype PrettyValue = PrettyValue { unPrettyValue :: Value } deriving (Eq, Read, Show, Generic, Typeable, Data, TH.Lift) deriving newtype (Hashable, IsString, FromJSON, ToJSON, NFData) @@ -343,7 +344,7 @@ cutOffCoPercent (abs -> offset) (abs -> full) (abs -> achieved) | otherwise = 1 where percent = achieved / full - + -- | @cutOffPercent offset full achieved@ returns a value between 0 and 1, measuring how close @achieved@ is to @full@@; 1 meaning very and 0 meaning not at all -- -- @offset@ specifies minimum result value, unless @achieved@ is zero @@ -580,7 +581,7 @@ catchMaybeT _ act = catch (lift act) (const mzero :: e -> MaybeT m a) catchMPlus :: forall p m e a. (MonadPlus m, MonadCatch m, Exception e) => p e -> m a -> m a catchMPlus _ = handle (const mzero :: e -> m a) - + catchIfMPlus :: forall m e a. (MonadPlus m, MonadCatch m, Exception e) => (e -> Bool) -> m a -> m a catchIfMPlus p act = catchIf p act (const mzero) @@ -703,7 +704,7 @@ shortCircuitM sc binOp mx my = do x <- mx if | sc x -> return x - | otherwise -> binOp <$> pure x <*> my + | otherwise -> binOp x <$> my guardM :: MonadPlus m => m Bool -> m () @@ -800,7 +801,7 @@ mconcatForM = flip mconcatMapM findM :: (Monad m, Foldable f) => (a -> MaybeT m b) -> f a -> m (Maybe b) findM f = runMaybeT . Fold.foldr (\x as -> f x <|> as) mzero - + yesodTimeout :: ( MonadHandler m , MonadUnliftIO m ) @@ -832,7 +833,7 @@ peekN n = do peeked <- catMaybes <$> replicateM (fromIntegral n) await mapM_ leftover peeked return peeked - + anyMC, allMC :: forall a o m. Monad m => (a -> m Bool) -> ConduitT a o m Bool anyMC f = C.mapM f .| orC allMC f = C.mapM f .| andC @@ -874,7 +875,7 @@ choice = foldr (<|>) empty ------------- -- Cookies -- ------------- - + -- Moved to Utils.Cookies.Registered -------------------- @@ -1170,8 +1171,7 @@ instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON Aeson.FromJSONKeyTextParser f -> Aeson.withObject "HashMap" $ fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) <$> f k Aeson. Aeson.Key k <*> parseJSON v Aeson. Aeson.Key k <*> m) (pure mempty) Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr -> - fmap (MergeHashMap . HashMap.fromListWith (<>)) . sequence . - zipWith (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr + fmap (MergeHashMap . HashMap.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr where uc :: Aeson.Parser (HashMap Text v) -> Aeson.Parser (MergeHashMap k v) uc = unsafeCoerce diff --git a/src/Utils/Allocation.hs b/src/Utils/Allocation.hs index 323985f6a..08ce49bd4 100644 --- a/src/Utils/Allocation.hs +++ b/src/Utils/Allocation.hs @@ -20,7 +20,7 @@ import Control.Monad.Writer (tell) import Control.Monad.ST -import Data.List ((!!), elemIndex) +import Data.List ((!!)) type CourseIndex = Int @@ -85,7 +85,7 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $ courses' <- lift . lift . MArr.newListArray courseBounds . map initCourse $ Set.toAscList courses :: RandT randomGen (WriterT _ (ST s)) (STArray s CourseIndex (Either (Set (student, CloneIndex)) (Seq (student, CloneIndex)))) stPrefs <- lift . lift $ MArr.newArray studentBounds [] :: RandT randomGen (WriterT _ (ST s)) (STArray s (StudentIndex, CloneIndex) [course]) - forM_ clonedStudents $ \(st, cn) -> + forM_ clonedStudents $ \(st, cn) -> lift . lift . MArr.writeArray stPrefs (st ^. contStudents, cn) $ studentPrefs cstb (st, cn) let @@ -127,11 +127,11 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $ (newSpots, lostSpots) = force . Seq.splitAt capacity $ betterSpots <> Seq.singleton (st, cn) <> worseSpots isUnstableWith :: CloneIndex -> (student, CloneIndex) -> Bool - isUnstableWith cn' (stO, cnO) = fromMaybe False $ do + isUnstableWith cn' (stO, cnO) = Just True == (do c' <- matchingCourse st cn' rMe <- courseRating c' (st, cn') rOther <- courseRating c' (stO, cnO) - return $ LT == compare (rMe, stb (st, cn')) (rOther, stb (stO, cnO)) + return $ LT == compare (rMe, stb (st, cn')) (rOther, stb (stO, cnO))) if | any (uncurry isUnstableWith) $ (,) <$> [0,1..pred cn] <*> toList lostSpots -> lift . tell . pure $ MatchingNoApplyCloneInstability st (fromIntegral cn) c @@ -181,10 +181,10 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $ -- caRb <- hoistMaybe $ rank (b, cnb) ca -- cbRa <- hoistMaybe $ rank (a, cna) cb -- cbRb <- hoistMaybe $ rank (b, cnb) cb - + -- let currentRanks cop = caRa `cop` cbRb -- newRanks cop = cbRa `cop` caRb - + -- swapImproves = or -- [ currentRanks (+) > newRanks (+) -- , currentRanks (+) == newRanks (+) @@ -239,7 +239,7 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $ cloneIndices :: cloneIndex -> cloneCount -> Set CloneIndex cloneIndices firstClone clones = Set.fromList $ map fromIntegral [firstClone, pred $ firstClone + fromIntegral clones] - + clonedStudents :: Set (student, CloneIndex) clonedStudents = Set.fromDistinctAscList $ do (student, (firstClone, clones)) <- Map.toAscList cloneCounts @@ -266,7 +266,7 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $ contCourses = iso toInt fromInt where courses' = Set.toAscList courses - + toInt = fromMaybe (error "trying to resolve unknown course") . flip elemIndex courses' fromInt = (!!) courses' diff --git a/src/Utils/Cookies/Registered.hs b/src/Utils/Cookies/Registered.hs index e94afb763..14a91c9fe 100644 --- a/src/Utils/Cookies/Registered.hs +++ b/src/Utils/Cookies/Registered.hs @@ -44,7 +44,7 @@ _CookieEncoded :: Prism' Text Text _CookieEncoded = prism' cEncode cDecode where b64Prefix = "base64url:" - + cDecode t | Just encoded <- Text.stripPrefix b64Prefix t = either (const Nothing) Just . Text.decodeUtf8' <=< either (const Nothing) Just . Base64.decode $ Text.encodeUtf8 encoded @@ -60,14 +60,14 @@ _CookieEncoded = prism' cEncode cDecode newtype RegisteredCookieCurrentValue = RegisteredCookieCurrentValue { getRegisteredCookieCurrentValue :: Maybe Text } deriving (Eq, Ord, Read, Show, Generic, Typeable) - + -- Primitive setRegisteredCookie' :: (Textual t, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => (SetCookie -> SetCookie) -> RegisteredCookie -> t -> m () setRegisteredCookie' modSet ident@(toPathPiece -> name) (review _CookieEncoded . repack -> content) = do path <- getCookiePath defSetCookie <- cookieSettingsToSetCookie . ($ ident) =<< getsYesod getCookieSettings - + setCookie $ modSet defSetCookie { setCookieName = Text.encodeUtf8 name , setCookieValue = Text.encodeUtf8 content @@ -114,7 +114,7 @@ deleteRegisteredCookie :: (MonadHandler m, Yesod (HandlerSite m)) => RegisteredC deleteRegisteredCookie name = deleteRegisteredCookie' name . Text.decodeUtf8 =<< getCookiePath -- Primitive -lookupRegisteredCookies :: (Textual t, Monoid m, MonadHandler f) => (t -> m) -> RegisteredCookie -> f m +lookupRegisteredCookies :: (Textual t, Monoid m, MonadHandler f) => (t -> m) -> RegisteredCookie -> f m lookupRegisteredCookies toM (toPathPiece -> name) = do cachedVal <- cacheByGet (Text.encodeUtf8 name) case cachedVal of diff --git a/src/Utils/Csv.hs b/src/Utils/Csv.hs index 0c071f864..c291ba7ee 100644 --- a/src/Utils/Csv.hs +++ b/src/Utils/Csv.hs @@ -11,10 +11,10 @@ module Utils.Csv import ClassyPrelude hiding (lookup) import Settings.Mime - + import Data.Csv hiding (Name) import Data.Csv.Conduit (CsvParseError) - + import Language.Haskell.TH (Name) import Language.Haskell.TH.Lib @@ -63,7 +63,7 @@ toCsvRendered :: forall mono. toCsvRendered csvRenderedHeader (otoList -> csvs) = CsvRendered{..} where csvRenderedData = map toNamedRecord csvs - + toDefaultOrderedCsvRendered :: forall mono. ( ToNamedRecord (Element mono) , DefaultOrdered (Element mono) diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index d33c5703f..8e0337492 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -33,7 +33,7 @@ getJustBy u = getBy u >>= maybe getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) => Unique record -> ReaderT backend m (Maybe (Key record)) getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record! - + getKeyJustBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record)) => Unique record -> ReaderT backend m (Key record) getKeyJustBy u = getKeyBy u >>= maybe @@ -46,7 +46,7 @@ getKeyBy404 u = getKeyBy u >>= maybe notFound return getEntity404 :: (PersistStoreRead backend, PersistRecordBackend val backend, MonadHandler m) => Key val -> ReaderT backend m (Entity val) -getEntity404 k = Entity <$> pure k <*> get404 k +getEntity404 k = Entity k <$> get404 k existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) => Unique record -> ReaderT backend m Bool diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index 01b009acf..27b30c9bf 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -44,7 +44,7 @@ import Algebra.Lattice import Algebra.Lattice.Ordered import Control.Monad.Fail - + -- $(timeLocaleMap _) :: [Lang] -> TimeLocale timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default @@ -55,7 +55,7 @@ timeLocaleMap extra@((_, defLocale):_) = do let langs = NonEmpty.fromList $ map fst extra - + localeMap' = funD localeMap $ map matchLang extra ++ [defaultLang] defaultLang :: ClauseQ @@ -69,7 +69,7 @@ timeLocaleMap extra@((_, defLocale):_) = do localeExp :: String -> ExpQ localeExp = lift <=< runIO . getLocale . Just - + letE [localeMap'] (varE localeMap) currentYear :: ExpQ @@ -83,7 +83,7 @@ class FormatTime t => HasLocalTime t where instance HasLocalTime LocalTime where toLocalTime = id - + instance HasLocalTime Day where toLocalTime d = LocalTime d midnight @@ -118,7 +118,7 @@ instance Lattice SelDateTimeFormat where instance BoundedJoinSemiLattice SelDateTimeFormat where bottom = SelFormatTime - + instance BoundedMeetSemiLattice SelDateTimeFormat where top = SelFormatDateTime diff --git a/src/Utils/Failover.hs b/src/Utils/Failover.hs index e8c51dae7..ea3dec8d5 100644 --- a/src/Utils/Failover.hs +++ b/src/Utils/Failover.hs @@ -75,7 +75,7 @@ mkFailover :: MonadIO m => PointedList a -> m (Failover a) mkFailover opts = fmap Failover . liftIO $ newTVarIO opts' - where opts' = flip (iover $ indexing traverse) opts $ \i failoverValue -> FailoverItem{ failoverLabel = tshow i, failoverLastTest = Nothing, failoverReferences = Set.empty, .. } + where opts' = flip (iover $ indexing traverse) opts $ \i failoverValue -> FailoverItem{ failoverLabel = tshow i, failoverLastTest = Nothing, failoverReferences = Set.empty, .. } mkFailoverLabeled :: MonadIO m => PointedList (Text, a) @@ -98,7 +98,7 @@ withFailoverReference :: (MonadIO m, MonadMask m) -> m b withFailoverReference Failover{..} cont = do ref <- liftIO newUnique - finally (cont ref) $ + finally (cont ref) $ atomically . modifyTVar failover $ traverse . _failoverReferences %~ Set.delete ref diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs index 8ccf64b13..284a4a890 100644 --- a/src/Utils/Files.hs +++ b/src/Utils/Files.hs @@ -29,7 +29,7 @@ import Control.Monad.Trans.Resource (allocate) sinkFiles :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => ConduitT File FileReference (SqlPersistT m) () sinkFiles = C.mapM sinkFile - + sinkFile :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => File -> SqlPersistT m FileReference sinkFile File{ fileContent = Nothing, .. } = return FileReference { fileReferenceContent = Nothing @@ -44,9 +44,9 @@ sinkFile File{ fileContent = Just fileContentContent, .. } = do insert FileLock{ fileLockContent = fileContentHash, .. } releaseLock lId = liftHandler . runDB $ (withReaderT projectBackend $ setSerializable (delete lId :: SqlPersistT (HandlerFor UniWorX) ()) :: YesodDB UniWorX ()) in unliftIO $ allocate (unliftIO takeLock) (unliftIO . releaseLock) - + inDB <- exists [ FileContentHash ==. fileContentHash ] - + let sinkFileDB = unless inDB $ repsert (FileContentKey fileContentHash) FileContent{ fileContentUnreferencedSince = Nothing, .. } maybeT sinkFileDB $ do let uploadName = decodeUtf8 . Base64.encodeUnpadded $ ByteArray.convert fileContentHash @@ -68,7 +68,7 @@ sinkFile File{ fileContent = Just fileContentContent, .. } = do } where fileContentHash = Crypto.hash fileContentContent - + sinkFiles' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX, HasFileReference record) => ConduitT (File, FileReferenceResidual record) record (SqlPersistT m) () sinkFiles' = C.mapM $ uncurry sinkFile' diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index e24753d90..f3e8461b1 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -165,7 +165,7 @@ addDatalist mkOptions field = field noValidate :: FieldSettings site -> FieldSettings site noValidate = addAttr "formnovalidate" "" - + noAutocomplete :: FieldSettings site -> FieldSettings site noAutocomplete = addAttr "autocomplete" "off" @@ -718,9 +718,9 @@ selectField' optMsg mkOpts = Field{..} let rendered = case val of Left _ -> "" - Right a -> maybe "" optionExternalValue . listToMaybe $ filter ((== a) . optionInternalValue) olOptions + Right a -> maybe "" optionExternalValue $ find ((== a) . optionInternalValue) olOptions - isSel Nothing = not $ rendered `elem` map optionExternalValue olOptions + isSel Nothing = rendered `notElem` map optionExternalValue olOptions isSel (Just opt) = rendered == optionExternalValue opt [whamlet| $newline never @@ -757,9 +757,9 @@ radioField' optMsg mkOpts = Field{..} let rendered = case val of Left _ -> "" - Right a -> maybe "" optionExternalValue . listToMaybe $ filter ((== a) . optionInternalValue) olOptions + Right a -> maybe "" optionExternalValue $ find ((== a) . optionInternalValue) olOptions - isSel Nothing = not $ rendered `elem` map optionExternalValue olOptions + isSel Nothing = rendered `notElem` map optionExternalValue olOptions isSel (Just opt) = rendered == optionExternalValue opt [whamlet| $newline never @@ -800,9 +800,9 @@ radioGroupField optMsg mkOpts = Field{..} let rendered = case val of Left _ -> "" - Right a -> maybe "" optionExternalValue . listToMaybe $ filter ((== a) . optionInternalValue) olOptions + Right a -> maybe "" optionExternalValue $ find ((== a) . optionInternalValue) olOptions - isSel Nothing = not $ rendered `elem` map optionExternalValue olOptions + isSel Nothing = rendered `notElem` map optionExternalValue olOptions isSel (Just opt) = rendered == optionExternalValue opt [whamlet| $newline never @@ -820,7 +820,7 @@ radioGroupField optMsg mkOpts = Field{..} #{optionDisplay opt} |] - + ----------- -- Forms -- ----------- @@ -885,9 +885,7 @@ renderFieldViews :: ( RenderMessage site AFormMessage ) => FormLayout -> [FieldView site] -> WidgetT site IO () renderFieldViews layout - = join - . fmap (view _1) - . generateFormPost + = view _1 <=< generateFormPost . lmap (const mempty) . renderWForm layout . (FormSuccess () <$) @@ -1160,7 +1158,7 @@ wFormFields = mapRWST (fmap (\((a, s, w'), w) -> ((a, w), s, w')) . censor (cons -- Special variants of @mopt@, @mreq@, ... -- --------------------------------------------- - + data ValueRequired site = forall msg. RenderMessage site msg => ValueRequired msg mreq :: forall m a. @@ -1168,21 +1166,21 @@ mreq :: forall m a. , RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m)) ) => Field m a -> FieldSettings (HandlerSite m) -> Maybe a -> MForm m (FormResult a, FieldView (HandlerSite m)) -mreq f fs@FieldSettings{..} mdef = mreqMsg f fs (ValueRequired fsLabel) mdef +mreq f fs@FieldSettings{..} = mreqMsg f fs $ ValueRequired fsLabel wreq :: forall m a. ( MonadHandler m , RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m)) ) => Field m a -> FieldSettings (HandlerSite m) -> Maybe a -> WForm m (FormResult a) -wreq f fs@FieldSettings{..} mdef = wreqMsg f fs (ValueRequired fsLabel) mdef +wreq f fs@FieldSettings{..} = wreqMsg f fs $ ValueRequired fsLabel areq :: forall m a. ( MonadHandler m , RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m)) ) => Field m a -> FieldSettings (HandlerSite m) -> Maybe a -> AForm m a -areq f fs@FieldSettings{..} mdef = areqMsg f fs (ValueRequired fsLabel) mdef +areq f fs@FieldSettings{..} = areqMsg f fs $ ValueRequired fsLabel mforced :: (site ~ HandlerSite m, MonadHandler m) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index a08246da3..4dae872f8 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -8,7 +8,7 @@ import Import.NoModel import Model import Model.Rating import qualified ClassyPrelude.Yesod as Yesod (HasHttpManager(..)) - + import Control.Lens as Utils.Lens hiding ( (<.>) , universe @@ -106,14 +106,14 @@ _entityVal = ilens ((,) <$> entityKey <*> entityVal) (\e v -> e { entityVal = v _Entity :: Iso (Entity record) (Entity record') (Key record, record) (Key record', record') _Entity = iso ((,) <$> entityKey <*> entityVal) (uncurry Entity) - + instance HasStudyFeatures a => HasStudyFeatures (Entity a) where hasStudyFeatures = _entityVal . hasStudyFeatures instance HasStudyTerms a => HasStudyTerms (Entity a) where hasStudyTerms = _entityVal . hasStudyTerms - + instance HasStudyDegree a => HasStudyDegree (Entity a) where hasStudyDegree = _entityVal . hasStudyDegree @@ -203,7 +203,7 @@ makeLenses_ ''CourseUserNote makeLenses_ ''CourseParticipant makeLenses_ ''CourseApplication - + makeLenses_ ''Allocation makeLenses_ ''Submission @@ -224,7 +224,7 @@ makeLenses_ ''AllocationUser makeLenses_ ''Tutorial makeLenses_ ''SessionFile - + makeLenses_ ''ExternalExam makeLenses_ ''ExternalExamOfficeSchool makeLenses_ ''ExternalExamStaff diff --git a/src/Utils/Lens/TH.hs b/src/Utils/Lens/TH.hs index e52157a18..34af447b7 100644 --- a/src/Utils/Lens/TH.hs +++ b/src/Utils/Lens/TH.hs @@ -69,7 +69,7 @@ makeClassyFor_ recName = makeFieldOptics (classyRulesFor_ clNamer) recName where clsName = "Has" <> nameBase recName funName = "has" <> nameBase recName - + clNamer :: ClassyNamer -- clNamer _ = Just (clsName, funName) -- for newer versions >= 4.17 clNamer _ = Just (mkName clsName, mkName funName) diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index f4d942b1d..514b6d1ca 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -24,6 +24,8 @@ import qualified Network.HTTP.Types as HTTP import Yesod.Core.Types (HandlerData(..), GHState(..)) +{-# ANN module ("HLint: ignore Use even" :: String) #-} + histogramBuckets :: Rational -- ^ min -> Rational -- ^ max @@ -40,7 +42,7 @@ histogramBuckets bMin bMax = map fromRational . takeWhile (<= bMax) . go bMin $ where bMin' :: Integer bMin' = floor . List.head . dropWhile (< 1) $ List.iterate (* 10) bMin - + {-# NOINLINE healthReportTime #-} healthReportTime :: Vector Label2 Gauge @@ -152,7 +154,7 @@ registerReadyMetric = liftIO $ void . register . readyMetric =<< getPOSIXTime withJobWorkerStateLbls :: (MonadIO m, MonadMask m) => Label4 -> m a -> m a withJobWorkerStateLbls newLbls act = do liftIO $ withLabel jobWorkerStateTransitions newLbls incCounter - + start <- liftIO $ getTime Monotonic res <- handleAll (return . Left) $ Right <$> act end <- liftIO $ getTime Monotonic @@ -160,7 +162,7 @@ withJobWorkerStateLbls newLbls act = do liftIO . withLabel jobWorkerStateDuration newLbls . flip observe . realToFrac $ end - start either throwM return res - + observeYesodCacheSize :: MonadHandler m => m () observeYesodCacheSize = do HandlerData{handlerState} <- liftHandler ask diff --git a/src/Utils/Occurrences.hs b/src/Utils/Occurrences.hs index 6b4051d89..ecd495dc4 100644 --- a/src/Utils/Occurrences.hs +++ b/src/Utils/Occurrences.hs @@ -50,7 +50,7 @@ normalizeOccurrences initial | otherwise = Nothing merge _ = Nothing - merges <- views _occurrencesScheduled $ mapMaybe (\b -> (,) <$> pure b <*> merge b) . Set.toList . Set.delete a + merges <- views _occurrencesScheduled $ mapMaybe (\b -> (b, ) <$> merge b) . Set.toList . Set.delete a case merges of [] -> return () ((b, merged) : _) -> throwE =<< asks (over _occurrencesScheduled $ Set.insert merged . Set.delete b . Set.delete a) diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index 2ca4e2573..f056be9c6 100644 --- a/src/Utils/Parameters.hs +++ b/src/Utils/Parameters.hs @@ -73,11 +73,11 @@ lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPie hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident) - + lookupGlobalPostParams :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m [result] lookupGlobalPostParams ident = mapMaybe fromPathPiece <$> lookupPostParams (toPathPiece ident) - + lookupGlobalPostParamForm :: (Monad m, PathPiece result) => GlobalPostParam -> MForm m (Maybe result) lookupGlobalPostParamForm ident = runMaybeT $ do ps <- MaybeT askParams diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index 8c429964f..11be9154b 100644 --- a/src/Utils/PathPiece.hs +++ b/src/Utils/PathPiece.hs @@ -36,7 +36,7 @@ import Control.Monad.Fail import Data.Binary (Binary) import qualified Data.Binary as Binary - + mkFiniteFromPathPiece :: Name -> Q ([Dec], Exp) mkFiniteFromPathPiece finiteType = do @@ -132,8 +132,8 @@ derivePathPiece adt mangle joinPP = do , clause [wildP] (normalB [e|Nothing|]) [] ] ] - - + + splitCamel :: Textual t => t -> [t] splitCamel = map fromList . reverse . helper (error "hasChange undefined at start of string") [] "" . otoList where @@ -169,7 +169,7 @@ tuplePathPiece tupleDim = do let tupleSeparator :: Text tupleSeparator = "," - + xs <- replicateM tupleDim $ newName "x" :: Q [Name] xs' <- replicateM tupleDim $ newName "x'" :: Q [Name] diff --git a/src/Utils/PersistentTokenBucket.hs b/src/Utils/PersistentTokenBucket.hs index 667898003..ca9f05f22 100644 --- a/src/Utils/PersistentTokenBucket.hs +++ b/src/Utils/PersistentTokenBucket.hs @@ -5,7 +5,7 @@ module Utils.PersistentTokenBucket ) where import Import.NoFoundation - + import qualified Data.Conduit.Combinators as C @@ -23,7 +23,7 @@ persistentTokenBucketTryAlloc' :: (MonadHandler m, HasAppSettings (HandlerSite m -> SqlPersistT m Bool persistentTokenBucketTryAlloc' tbsIdent tokens = do TokenBucketConf{..} <- getsYesod $ views _appPersistentTokenBuckets ($ tbsIdent) - persistentTokenBucketTryAlloc TokenBucketSettings + persistentTokenBucketTryAlloc TokenBucketSettings { tbsIdent , tbsDepth = tokenBucketDepth , tbsInvRate = tokenBucketInvRate @@ -65,7 +65,7 @@ persistentTokenBucketTakeC' :: forall i m a. -> ConduitT i i (ReaderT SqlBackend m) () persistentTokenBucketTakeC' tbsIdent cTokens = do TokenBucketConf{..} <- getsYesod $ views _appPersistentTokenBuckets ($ tbsIdent) - persistentTokenBucketTakeC TokenBucketSettings + persistentTokenBucketTakeC TokenBucketSettings { tbsIdent , tbsDepth = tokenBucketDepth , tbsInvRate = tokenBucketInvRate @@ -78,7 +78,7 @@ persistentTokenBucketTakeC :: forall i m a. -> (i -> a) -> ConduitT i i (ReaderT SqlBackend m) () persistentTokenBucketTakeC tbs cTokens = C.mapAccumWhileM tbAccum () - where tbAccum :: i + where tbAccum :: i -> () -> SqlPersistT m (Either () ((), i)) tbAccum x () diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index b3ad49706..2a03a76da 100644 --- a/src/Utils/Sql.hs +++ b/src/Utils/Sql.hs @@ -20,7 +20,7 @@ import Control.Lens ((&)) setSerializable :: forall m a. (MonadLogger m, MonadMask m, MonadIO m, ReadLogSettings (SqlPersistT m)) => SqlPersistT m a -> SqlPersistT m a setSerializable = setSerializable' $ fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 10e6 - + setSerializable' :: forall m a. (MonadLogger m, MonadMask m, MonadIO m, ReadLogSettings (SqlPersistT m)) => RetryPolicyM (SqlPersistT m) -> SqlPersistT m a -> ReaderT SqlBackend m a setSerializable' policy act = do LogSettings{logSerializableTransactionRetryLimit} <- readLogSettings @@ -29,7 +29,7 @@ setSerializable' policy act = do where suggestRetry :: SqlError -> ReaderT SqlBackend m Bool suggestRetry = return . isSerializationError - + logRetry :: Maybe Natural -> Bool -- ^ Will retry -> SqlError @@ -55,4 +55,4 @@ setSerializable' policy act = do return res - + diff --git a/src/Utils/Tokens.hs b/src/Utils/Tokens.hs index 2a23db3b9..f29aa5da9 100644 --- a/src/Utils/Tokens.hs +++ b/src/Utils/Tokens.hs @@ -67,7 +67,7 @@ bearerToken bearerAuthority bearerRoutes bearerAddAuth mBearerExpiresAt bearerSt bearerIssuedFor <- getsYesod $ view clusterID defaultExpiration <- getsYesod $ view _appBearerExpiration - + let bearerExpiresAt | Just t <- mBearerExpiresAt = t diff --git a/src/Web/ServerSession/Backend/Persistent/Memcached.hs b/src/Web/ServerSession/Backend/Persistent/Memcached.hs index bdf4df53b..b2a56a396 100644 --- a/src/Web/ServerSession/Backend/Persistent/Memcached.hs +++ b/src/Web/ServerSession/Backend/Persistent/Memcached.hs @@ -17,7 +17,7 @@ import Web.ServerSession.Core import Database.Persist.Sql (ConnectionPool, runSqlPool) import qualified Data.Binary as Binary - + import qualified Database.Memcached.Binary.IO as Memcached import qualified Crypto.Saltine.Class as Saltine @@ -111,7 +111,7 @@ instance (IsSessionData sess, Binary (Decomposed sess)) => Storage (MemcachedSql runTransactionM MemcachedSqlStorage{..} = flip runSqlPool mcdSqlConnPool getSession MemcachedSqlStorage{..} sessId = exceptT (maybe (return Nothing) throwM) (return . Just) $ do - encSession <- catchIfExceptT (\_ -> Nothing) Memcached.isKeyNotFound . liftIO . fmap LBS.toStrict $ Memcached.getAndTouch_ expiry (memcachedSqlSessionId # sessId) mcdSqlMemcached + encSession <- catchIfExceptT (const Nothing) Memcached.isKeyNotFound . liftIO . fmap LBS.toStrict $ Memcached.getAndTouch_ expiry (memcachedSqlSessionId # sessId) mcdSqlMemcached guardExceptT (BS.length encSession >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $ Just MemcachedSqlStorageAEADCiphertextTooShort @@ -129,10 +129,10 @@ instance (IsSessionData sess, Binary (Decomposed sess)) => Storage (MemcachedSql expiration <- runMaybeT $ fmap (memcachedSessionExpirationTime . entityVal) . MaybeT . lift . getBy . UniqueMemcachedSessionExpiration =<< hoistMaybe mcdSqlSessionAuthId guardExceptT (maybe True (mcdSqlSessionCreatedAt >) expiration) Nothing - + return $ (sessId, decoded) ^. memcachedSqlSession - where expiry = maybe 0 ceiling mcdSqlMemcachedExpiration + where expiry = maybe 0 ceiling mcdSqlMemcachedExpiration deleteSession MemcachedSqlStorage{..} sessId = liftIO . handleIf Memcached.isKeyNotFound (const $ return ()) $ Memcached.delete (memcachedSqlSessionId # sessId) mcdSqlMemcached @@ -161,7 +161,7 @@ replaceSession' isReplace s@MemcachedSqlStorage{..} seNewSession@(review memcach whenIsJust mOld $ \seExistingSession -> throwM @_ @(StorageException (MemcachedSqlStorage sess)) $ SessionAlreadyExists{..} - nonce <- liftIO $ AEAD.newNonce + nonce <- liftIO AEAD.newNonce let encSession = Saltine.encode nonce <> AEAD.aead mcdSqlMemcachedKey nonce encoded encSessId encSessId = LBS.toStrict $ Binary.encode sessId handleFailure @@ -172,4 +172,4 @@ replaceSession' isReplace s@MemcachedSqlStorage{..} seNewSession@(review memcach where encoded = LBS.toStrict $ Binary.encode decoded - expiry = maybe 0 ceiling mcdSqlMemcachedExpiration + expiry = maybe 0 ceiling mcdSqlMemcachedExpiration diff --git a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs index e4297a510..341fb2291 100644 --- a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs +++ b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs @@ -35,7 +35,7 @@ import qualified Data.Aeson as JSON instance Universe ForceInvalidate instance Finite ForceInvalidate -finitePathPiece ''ForceInvalidate +finitePathPiece ''ForceInvalidate [ "current", "all", "none" ] @@ -86,7 +86,7 @@ backend jwtCfg getApprootText' state = pure $ Just SessionBackend{..} approot' = getApprootText' req return (sessionData, save) - + findSession :: State sto -> Wai.Request -> Maybe Jwt @@ -130,7 +130,7 @@ createCookie state approot' session (Jwt payload) = AddCookie def , setCookieSecure = getSecureCookies state } - + decodeSession :: ( MonadThrow m , MonadIO m ) @@ -157,7 +157,7 @@ encodeSession :: MonadIO m => ServerSessionJwtConfig -> SessionToken sess -> m Jwt -encodeSession ServerSessionJwtConfig{..} token = liftIO $ +encodeSession ServerSessionJwtConfig{..} token = liftIO $ either throwM return =<< Jose.encode (Jose.keys sJwtJwkSet) sJwtEncoding payload where payload = Jose.Claims . toStrict $ JSON.encode token diff --git a/src/Yesod/Core/Instances.hs b/src/Yesod/Core/Instances.hs index 17838c4b8..76e480a8f 100644 --- a/src/Yesod/Core/Instances.hs +++ b/src/Yesod/Core/Instances.hs @@ -54,7 +54,7 @@ routeToPathPiece instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where fromPathPiece = routeFromPathPiece toPathPiece = routeToPathPiece - + instance ParseRoute site => FromJSON (Route site) where parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . routeFromPathPiece diff --git a/src/Yesod/Core/Types/Instances.hs b/src/Yesod/Core/Types/Instances.hs index e05f92f0d..924c27673 100644 --- a/src/Yesod/Core/Types/Instances.hs +++ b/src/Yesod/Core/Types/Instances.hs @@ -33,7 +33,7 @@ import Control.Monad.Morph (MFunctor, MMonad) deriving via (ReaderT (HandlerData site site) IO) instance MonadFix (HandlerFor site) deriving via (ReaderT (HandlerData sub site) IO) instance MonadFix (SubHandlerFor sub site) deriving via (ReaderT (WidgetData site) IO) instance MonadFix (WidgetFor site) - + deriving via (ReaderT (HandlerData site site) IO) instance MonadCatch (HandlerFor site) deriving via (ReaderT (HandlerData sub site) IO) instance MonadCatch (SubHandlerFor sub site) deriving via (ReaderT (WidgetData site) IO) instance MonadCatch (WidgetFor site) diff --git a/src/Yesod/Form/Fields/Instances.hs b/src/Yesod/Form/Fields/Instances.hs index a35ed24ce..c77b1e4ea 100644 --- a/src/Yesod/Form/Fields/Instances.hs +++ b/src/Yesod/Form/Fields/Instances.hs @@ -13,7 +13,7 @@ deriving instance Foldable Option deriving instance Traversable Option instance Foldable OptionList where - foldMap f OptionList{..} = foldMap (foldMap f) olOptions + foldMap f OptionList{..} = foldMap (foldMap f) olOptions instance Semigroup (OptionList a) where diff --git a/stack.yaml b/stack.yaml index ebd6b03a3..b0eae426c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -151,6 +151,7 @@ extra-deps: - unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144 - uuid-crypto-1.4.0.0@sha256:9e2f271e61467d9ea03e78cddad75a97075d8f5108c36a28d59c65abb3efd290,1325 - wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314 + - hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814 resolver: nightly-2020-08-08 allow-newer: true diff --git a/stack.yaml.lock b/stack.yaml.lock index 398eecca6..fd5569286 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -150,6 +150,20 @@ packages: subdir: colonnade git: git@gitlab2.rz.ifi.lmu.de:uni2work/colonnade.git commit: f8170266ab25b533576e96715bedffc5aa4f19fa +- completed: + cabal-file: + size: 9845 + sha256: 674630347209bc5f7984e8e9d93293510489921f2d2d6092ad1c9b8c61b6560a + name: minio-hs + version: 1.5.2 + git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git + pantry-tree: + size: 4560 + sha256: c5faff15fa22a7a63f45cd903c9bd11ae03f422c26f24750f5c44cb4d0db70fc + commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1 + original: + git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git + commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1 - completed: hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207 pantry-tree: @@ -367,6 +381,13 @@ packages: sha256: 6d64803c639ed4c7204ea6fab0536b97d3ee16cdecb9b4a883cd8e56d3c61402 original: hackage: wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314 +- completed: + hackage: hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814 + pantry-tree: + size: 442 + sha256: 347eac6c8a3c02fc0101444d6526b57b3c27785809149b12f90d8db57c721fea + original: + hackage: hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814 snapshots: - completed: size: 524392 From 2b9c2602bfbf05dac951b868c86941d77e6e579c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 11 Aug 2020 10:56:43 +0200 Subject: [PATCH 4/8] refactor: hlint --- src/Foundation.hs | 4 ++-- src/Handler/Sheet/Edit.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 489587bff..9a1200ab5 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1650,8 +1650,8 @@ wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff => [(AuthTag, Bool)] -- ^ Assumptions -> Route UniWorX -> m Bool -wouldHaveReadAccessToIff assumptions route = and2M (fmap not $ hasReadAccessTo route) $ wouldHaveReadAccessTo assumptions route -wouldHaveWriteAccessToIff assumptions route = and2M (fmap not $ hasWriteAccessTo route) $ wouldHaveWriteAccessTo assumptions route +wouldHaveReadAccessToIff assumptions route = and2M (not <$> hasReadAccessTo route) $ wouldHaveReadAccessTo assumptions route +wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo route) $ wouldHaveWriteAccessTo assumptions route -- | Conditional redirect that hides the URL if the user is not authorized for the route redirectAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a diff --git a/src/Handler/Sheet/Edit.hs b/src/Handler/Sheet/Edit.hs index 9d128c4f8..4857e6646 100644 --- a/src/Handler/Sheet/Edit.hs +++ b/src/Handler/Sheet/Edit.hs @@ -86,7 +86,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do , sheetAutoDistribute = sfAutoDistribute , sheetAnonymousCorrection = sfAnonymousCorrection , sheetRequireExamRegistration = sfRequireExamRegistration - , sheetAllowNonPersonalisedSubmission = fromMaybe True $ spffAllowNonPersonalisedSubmission <$> sfPersonalF + , sheetAllowNonPersonalisedSubmission = maybe True spffAllowNonPersonalisedSubmission sfPersonalF } mbsid <- dbAction newSheet case mbsid of @@ -98,7 +98,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do insertSheetFile' sid SheetMarking $ fromMaybe (return ()) sfMarkingF runConduit $ maybe (return ()) (transPipe liftHandler) (spffFiles =<< sfPersonalF) - .| sinkPersonalisedSheetFiles cid sid (fromMaybe False $ spffFilesKeepExisting <$> sfPersonalF) + .| sinkPersonalisedSheetFiles cid sid (maybe False spffFilesKeepExisting sfPersonalF) insert_ $ SheetEdit aid actTime sid addMessageI Success $ MsgSheetEditOk tid ssh csh sfName -- Sanity checks generating warnings only, but not errors! From eceb6a6c45f24970951c6ce5c0d646f9d777d202 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 11 Aug 2020 11:51:36 +0200 Subject: [PATCH 5/8] chore(release): 18.6.0 --- CHANGELOG.md | 49 +++++++++++++++++++++++++++++++++++++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 52 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index eb67e3710..73b7f7d60 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,55 @@ 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. +## [18.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.5.0...v18.6.0) (2020-08-11) + + +### Bug Fixes + +* **personalised-sheet-files:** more thorough check wrt sub-warnings ([0b0eaff](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0b0eaff)) +* hlint ([5ea7816](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5ea7816)) +* **course-visibility:** (more) correct visibility check for favourites ([796a806](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/796a806)) +* **course-visibility:** account for active auth tags everywhere ([c99433c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c99433c)) +* **course-visibility:** allow access for admin-like roles ([7569195](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7569195)) +* **course-visibility:** allow deregistration from invisible courses ([29da6e2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/29da6e2)) +* **course-visibility:** allow for caching Nothing results of getBy ([f129ce6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f129ce6)) +* **course-visibility:** check for mayEdit on course list ([b1d0893](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b1d0893)) +* **course-visibility:** correctly count courses on AllocationListR ([7530287](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7530287)) +* **course-visibility:** fix favourites ([1ac3c08](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1ac3c08)) +* **course-visibility:** rework routes ([7ce60a3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7ce60a3)) +* **course-visibility:** show icon to lecturers only ([cbb8e72](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cbb8e72)) +* **course-visibility:** visibility for admin-like users ([43f625b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/43f625b)) + + +### Features + +* **course-visibility:** account for visibility in routes ([cb0bf15](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cb0bf15)) +* **course-visibility:** account for visibility on AllocationListR ([4185742](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4185742)) +* **course-visibility:** account for visibility on AShowR ([df7a784](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/df7a784)) +* **course-visibility:** account for visibility on TShowR ([0ff07a5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0ff07a5)) +* **course-visibility:** add invisible icon to CShowR title ([6c0adde](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6c0adde)) +* **course-visibility:** add visibleFrom,visibleTo ([222d566](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/222d566)) +* **course-visibility:** allow access for exam correctors ([dfa70ee](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/dfa70ee)) +* **course-visibility:** display icon in course list for lecturers ([17dbccf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/17dbccf)) +* **course-visibility:** error on visibleFrom > visibleTo ([9494019](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9494019)) +* **course-visibility:** hide invisible courses from favourites + icon ([d86fed7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d86fed7)) +* **course-visibility:** more precise description on CShowR ([6fbb2ea](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6fbb2ea)) +* **course-visibility:** no invisible courses in course list ([24f1289](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/24f1289)) +* **course-visibility:** now as default visibleFrom for new courses ([7bdf8ca](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7bdf8ca)) +* **course-visibility:** redirect to NewsR after deregister (WIP!) ([183aa8d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/183aa8d)) +* **course-visibility:** reorder course form ([7af82bc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7af82bc)) +* **course-visibility:** rework visibility check for ZA courses ([a16eb1a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a16eb1a)) +* **course-visibility:** warn on deregister from invisible course ([16ad72d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/16ad72d)) +* **course-visibility:** warn on invisibility during registration ([23aca1c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/23aca1c)) +* **personalised-sheet-files:** collated ignore ([1fe63a2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1fe63a2)) +* **personalised-sheet-files:** download from CUsersR ([93d0ace](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/93d0ace)) +* **personalised-sheet-files:** finish upload functionality ([ed5fb6e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ed5fb6e)) +* **personalised-sheet-files:** i18n ([f452b2b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f452b2b)) +* **personalised-sheet-files:** introduce routes & work on crypto ([9ee44aa](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9ee44aa)) +* **personalised-sheet-files:** participant interaction ([db205f6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/db205f6)) + + + ## [18.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.4.0...v18.5.0) (2020-08-03) diff --git a/package-lock.json b/package-lock.json index db0d4db57..6bfad6734 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "18.5.0", + "version": "18.6.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index c5e99919c..725f5f8e4 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "18.5.0", + "version": "18.6.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 7cb2afde6..162fb8079 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 18.5.0 +version: 18.6.0 dependencies: - base From c68a01d7ae26bfa61306e143d663d28f641d0998 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 14 Aug 2020 17:00:35 +0200 Subject: [PATCH 6/8] refactor: split foundation & llvm BREAKING CHANGE: split foundation --- .gitlab-ci.yml | 18 +- package.yaml | 40 +- src/Database/Persist/Sql/Types/Instances.hs | 22 + src/Foundation.hs | 5291 +---------------- src/Foundation/Authorization.hs | 1475 +++++ src/Foundation/DB.hs | 46 + src/Foundation/I18n.hs | 45 +- src/Foundation/Instances.hs | 203 + src/Foundation/Navigation.hs | 2239 +++++++ src/Foundation/Routes.hs | 4 +- src/Foundation/SiteLayout.hs | 569 ++ src/Foundation/Type.hs | 7 + src/Foundation/Yesod/Auth.hs | 498 ++ src/Foundation/Yesod/ErrorHandler.hs | 90 + src/Foundation/Yesod/Middleware.hs | 251 + src/Foundation/Yesod/Persist.hs | 44 + src/Foundation/Yesod/Session.hs | 62 + src/Foundation/Yesod/StaticContent.hs | 49 + src/Handler/Admin.hs | 2 - src/Handler/Admin/Tokens.hs | 2 +- src/Handler/CryptoIDDispatch.hs | 4 +- src/Handler/Info.hs | 8 +- src/Handler/Profile.hs | 2 + src/Handler/Sheet.hs | 2 - src/Handler/Sheet/Current.hs | 1 + src/Handler/Submission.hs | 2 + src/Handler/Utils.hs | 18 + src/Handler/Utils/Form.hs | 2 - .../Utils/Form/MassInput/Liveliness.hs | 3 +- src/Handler/Utils/Invitations.hs | 10 +- src/Handler/Utils/Memcached.hs | 6 +- src/Handler/Utils/Table/Pagination.hs | 11 +- src/Handler/Utils/Users.hs | 1 + src/Handler/Utils/Widgets.hs | 6 - src/Import/NoModel.hs | 4 + src/Jobs/Handler/SynchroniseLdap.hs | 1 + src/Mail.hs | 4 +- src/Model/Types/File.hs | 2 +- src/Settings.hs | 7 + src/Settings/Cluster.hs | 4 +- src/Utils.hs | 1 - src/Utils/DB.hs | 24 +- src/Utils/Form.hs | 3 +- src/Utils/SystemMessage.hs | 6 +- src/Utils/Widgets.hs | 13 + stack.yaml | 3 + stack.yaml.lock | 7 + test/ModelSpec.hs | 2 + 48 files changed, 5740 insertions(+), 5374 deletions(-) create mode 100644 src/Database/Persist/Sql/Types/Instances.hs create mode 100644 src/Foundation/Authorization.hs create mode 100644 src/Foundation/DB.hs create mode 100644 src/Foundation/Instances.hs create mode 100644 src/Foundation/Navigation.hs create mode 100644 src/Foundation/SiteLayout.hs create mode 100644 src/Foundation/Yesod/Auth.hs create mode 100644 src/Foundation/Yesod/ErrorHandler.hs create mode 100644 src/Foundation/Yesod/Middleware.hs create mode 100644 src/Foundation/Yesod/Persist.hs create mode 100644 src/Foundation/Yesod/Session.hs create mode 100644 src/Foundation/Yesod/StaticContent.hs create mode 100644 src/Utils/Widgets.hs diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 28fe57b4c..08d737859 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -32,13 +32,13 @@ npm install: before_script: &npm - rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d - install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list - - apt-get update -y + - apt update -y - npm install -g n - n 13.5.0 - export PATH="${N_PREFIX}/bin:$PATH" - npm install -g npm - hash -r - - apt-get -y install openssh-client exiftool + - apt -y install openssh-client exiftool - install -v -m 0700 -d ~/.ssh - install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts - install -v -T -m 0400 ${SSH_DEPLOY_KEY} ~/.ssh/deploy && echo "IdentityFile ~/.ssh/deploy" >> ~/.ssh/config; @@ -93,9 +93,9 @@ yesod:build:dev: before_script: &haskell - rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d - install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list - - apt-get update -y - - apt-get install -y --no-install-recommends locales-all - - apt-get install openssh-client -y + - curl https://apt.llvm.org/llvm-snapshot.gpg.key | apt-key add - + - apt update -y + - apt install -y --no-install-recommends locales-all openssh-client clang-9 lldb-9 lld-9 clangd-9 - install -v -m 0700 -d ~/.ssh - install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts - install -v -T -m 0400 ${SSH_DEPLOY_KEY} ~/.ssh/deploy && echo "IdentityFile ~/.ssh/deploy" >> ~/.ssh/config; @@ -143,13 +143,13 @@ frontend:test: before_script: - rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d - install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list - - apt-get update -y + - apt update -y - npm install -g n - n 13.5.0 - export PATH="${N_PREFIX}/bin:$PATH" - npm install -g npm - hash -r - - apt-get install -y --no-install-recommends chromium-browser + - apt install -y --no-install-recommends chromium-browser dependencies: - npm install retry: 2 @@ -243,8 +243,8 @@ deploy:uniworx3: before_script: - rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d - install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list - - apt-get update -y - - apt-get install -y --no-install-recommends openssh-client + - apt update -y + - apt install -y --no-install-recommends openssh-client - install -v -m 0700 -d ~/.ssh - install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts - install -v -T -m 0400 ${SSH_PRIVATE_KEY_UNIWORX3} ~/.ssh/uniworx3; echo "IdentityFile ~/.ssh/uniworx3" >> ~/.ssh/config; diff --git a/package.yaml b/package.yaml index 162fb8079..34a56b449 100644 --- a/package.yaml +++ b/package.yaml @@ -63,7 +63,6 @@ dependencies: - cryptoids-class - binary - binary-instances - - cereal - mtl - esqueleto >=3.1.0 - mime-types @@ -210,6 +209,8 @@ default-extensions: - TypeFamilyDependencies - QuantifiedConstraints - EmptyDataDeriving + - StandaloneKindSignatures + - NoStarIsType ghc-options: - -Wall @@ -229,42 +230,41 @@ when: ghc-options: - -Werror - -fwarn-tabs + - condition: flag(dev) + then: + ghc-options: + - -O0 + - -ddump-splices + - -ddump-to-file + cpp-options: -DDEVELOPMENT + ghc-prof-options: + - -fprof-auto + else: + ghc-options: + - -O -fllvm # The library contains all of our application code. The executable # defined below is just a thin wrapper. library: source-dirs: src - when: - - condition: flag(dev) - then: - ghc-options: - - -O0 - - -ddump-splices - - -ddump-to-file - cpp-options: -DDEVELOPMENT - ghc-prof-options: - - -fprof-auto - else: - ghc-options: - - -O2 # Runnable executable for our application executables: uniworx: main: main.hs source-dirs: app - ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T -xn" dependencies: - uniworx when: - condition: flag(library-only) buildable: false + ghc-options: + - -threaded -rtsopts "-with-rtsopts=-N -T -xn" uniworxdb: main: Database.hs ghc-options: - -main-is Database - - -threaded - - -rtsopts "-with-rtsopts=-N -T" + - -threaded -rtsopts "-with-rtsopts=-N -T -xn" source-dirs: test dependencies: - uniworx @@ -277,8 +277,7 @@ executables: main: Load.hs ghc-options: - -main-is Load - - -threaded - - -rtsopts "-with-rtsopts=-N -T -xn" + - -threaded -rtsopts "-with-rtsopts=-N -T -xn" source-dirs: load dependencies: - uniworx @@ -312,8 +311,7 @@ tests: - yesod-persistent ghc-options: - -fno-warn-orphans - - -threaded - - -rtsopts "-with-rtsopts=-N -xn" + - -threaded -rtsopts "-with-rtsopts=-N -T -xn" hlint: main: Hlint.hs other-modules: [] diff --git a/src/Database/Persist/Sql/Types/Instances.hs b/src/Database/Persist/Sql/Types/Instances.hs new file mode 100644 index 000000000..b7c33572b --- /dev/null +++ b/src/Database/Persist/Sql/Types/Instances.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Database.Persist.Sql.Types.Instances + ( + ) where + +import ClassyPrelude + +import Database.Persist.Sql + + +instance BackendCompatible SqlWriteBackend SqlWriteBackend where + projectBackend = id + +instance BackendCompatible SqlReadBackend SqlReadBackend where + projectBackend = id + +instance BackendCompatible SqlReadBackend SqlBackend where + projectBackend = SqlReadBackend + +instance BackendCompatible SqlWriteBackend SqlBackend where + projectBackend = SqlWriteBackend diff --git a/src/Foundation.hs b/src/Foundation.hs index 9a1200ab5..6a9988f6c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedLabels #-} -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-uni-patterns -fno-warn-redundant-constraints #-} -- MonadCrypto - module Foundation ( module Foundation ) where @@ -12,5282 +6,9 @@ import Foundation.Type as Foundation import Foundation.Types as Foundation import Foundation.I18n as Foundation import Foundation.Routes as Foundation - - -import Import.NoFoundation hiding (embedFile) -import Database.Persist.Sql - ( runSqlPool, transactionUndo, SqlReadBackend(..) ) -import Text.Hamlet (hamletFile) - -import Yesod.Auth.Message -import Auth.LDAP -import Auth.PWHash -import Auth.Dummy - -import qualified Network.Wai as W -import qualified Network.HTTP.Types.Header as W -import qualified Network.Wai.Middleware.HttpAuth as W (extractBearerAuth) - -import qualified Yesod.Core.Unsafe as Unsafe -import qualified Data.CaseInsensitive as CI - -import Data.ByteArray (convert) -import Crypto.Hash (SHAKE256, SHAKE128) -import Crypto.Hash.Conduit (sinkHash) -import qualified Data.UUID as UUID -import qualified Data.Binary as Binary - -import qualified Data.ByteString.Base64.URL as Base64 (encode) - -import qualified Data.ByteString.Lazy as Lazy.ByteString -import qualified Data.ByteString as ByteString - -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text - -import qualified Data.Set as Set -import Data.Map ((!?)) -import qualified Data.Map as Map -import qualified Data.HashSet as HashSet -import qualified Data.HashMap.Strict as HashMap -import qualified Data.List.NonEmpty as NonEmpty - -import Data.List ((!!), findIndex, inits) -import qualified Data.List as List - -import Data.Conduit.List (sourceList) - -import qualified Database.Esqueleto as E -import qualified Database.Esqueleto.Utils as E - -import Control.Monad.Except (MonadError(..)) -import Control.Monad.Trans.State (execStateT) -import Control.Monad.Writer.Class (MonadWriter(..)) -import Control.Monad.Memo.Class (MonadMemo(..), for4) -import Control.Monad.Reader.Class (MonadReader(local)) -import qualified Control.Monad.Catch as C - -import Handler.Utils.StudyFeatures -import Handler.Utils.SchoolLdap -import Handler.Utils.ExamOffice.Exam -import Handler.Utils.ExamOffice.ExternalExam -import Handler.Utils.ExamOffice.Course -import Handler.Utils.Profile -import Handler.Utils.Routes -import Handler.Utils.Memcached -import Utils.Course (courseIsVisible) -import Utils.Form -import Utils.Sheet -import Utils.SystemMessage -import Utils.Metrics - -import Text.Cassius (cassiusFile) - -import qualified Yesod.Auth.Message as Auth - -import qualified Data.Conduit.List as C - -import qualified Database.Memcached.Binary.IO as Memcached -import Data.Bits (Bits(zeroBits)) - -import Network.Wai.Parse (lbsBackEnd) - -import qualified Data.Aeson as JSON -import Data.Aeson.Lens hiding (_Value, key) - -import Data.FileEmbed (embedFile) - -import qualified Ldap.Client as Ldap - -import UnliftIO.Pool - -import qualified Web.ServerSession.Core as ServerSession -import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession - -import Web.Cookie - -import Yesod.Core.Types (GHState(..), HandlerData(..), HandlerContents, RunHandlerEnv(rheSite, rheChild)) - -import qualified Control.Retry as Retry -import GHC.IO.Exception (IOErrorType(OtherError)) - --- | Convenient Type Synonyms: -type DB = YesodDB UniWorX -type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, Widget) -type MsgRenderer = MsgRendererS UniWorX -- see Utils -type MailM a = MailT (HandlerFor UniWorX) a - --- Requires `rendeRoute`, thus cannot currently be moved to Foundation.I18n -instance RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)) where - renderMessage f ls (UnsupportedAuthPredicate tag route) = mr . MsgUnsupportedAuthPredicate (mr tag) $ Text.intercalate "/" pieces - where - mr :: forall msg. RenderMessage UniWorX msg => msg -> Text - mr = renderMessage f ls - (pieces, _) = renderRoute route - -data NavQuickView - = NavQuickViewFavourite - | NavQuickViewPageActionSecondary - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) - deriving (Universe, Finite) - -navQuick :: NavQuickView -> (NavQuickView -> Any) -navQuick x x' = Any $ x == x' - -data NavType - = NavTypeLink - { navModal :: Bool - } - | NavTypeButton - { navMethod :: StdMethod - , navData :: [(Text, Text)] - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving anyclass (Binary) - -makeLenses_ ''NavType -makePrisms ''NavType - -data NavLevel = NavLevelTop | NavLevelInner - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) - -data NavHeaderRole = NavHeaderPrimary | NavHeaderSecondary - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) - -data NavLink = forall msg route. (RenderMessage UniWorX msg, HasRoute UniWorX route, RedirectUrl UniWorX route) => NavLink - { navLabel :: msg - , navRoute :: route - , navAccess' :: Handler Bool - , navType :: NavType - , navQuick' :: NavQuickView -> Any - , navForceActive :: Bool - } - -makeLenses_ ''NavLink - -instance HasRoute UniWorX NavLink where - urlRoute NavLink{..} = urlRoute navRoute -instance RedirectUrl UniWorX NavLink where - toTextUrl NavLink{..} = toTextUrl navRoute -instance RenderMessage UniWorX NavLink where - renderMessage app ls NavLink{..} = renderMessage app ls navLabel - -data Nav - = NavHeader - { navHeaderRole :: NavHeaderRole - , navIcon :: Icon - , navLink :: NavLink - } - | NavHeaderContainer - { navHeaderRole :: NavHeaderRole - , navLabel :: SomeMessage UniWorX - , navIcon :: Icon - , navChildren :: [NavLink] - } - | NavPageActionPrimary - { navLink :: NavLink - , navChildren :: [NavLink] - } - | NavPageActionSecondary - { navLink :: NavLink - } - | NavFooter - { navLink :: NavLink - } deriving (Generic, Typeable) - -makeLenses_ ''Nav -makePrisms ''Nav - -data NavChildren -type instance Children NavChildren a = ChildrenNavChildren a -type family ChildrenNavChildren a where - ChildrenNavChildren (SomeMessage UniWorX) = '[] - - ChildrenNavChildren a = Children ChGeneric a - -navAccess :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => Nav -> MaybeT m Nav -navAccess = execStateT $ do - guardM $ preuse _navLink >>= maybe (return True) navLinkAccess - - _navChildren <~ (filterM navLinkAccess =<< use _navChildren) - whenM (hasn't _navLink <$> use id) $ - guardM $ not . null <$> use _navChildren - -navLinkAccess :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => NavLink -> m Bool -navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M` accessCheck navType navRoute - where - shortCircuit :: HandlerContents -> m Bool - shortCircuit _ = return False - - accessCheck :: HasRoute UniWorX route => NavType -> route -> m Bool - accessCheck nt (urlRoute -> route) = do - authCtx <- getAuthContext - $memcachedByHere (Just $ Right 120) (authCtx, nt, route) $ - bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route - - -getTimeLocale' :: [Lang] -> TimeLocale -getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")]) - -appTZ :: TZ -appTZ = $(includeSystemTZ "Europe/Berlin") - -appLanguagesOpts :: ( MonadHandler m - , HandlerSite m ~ UniWorX - ) => m (OptionList Lang) --- ^ Authoritive list of supported Languages -appLanguagesOpts = do - MsgRenderer mr <- getMsgRenderer - let mkOption l = Option - { optionDisplay = mr $ MsgLanguage l - , optionInternalValue = l - , optionExternalValue = l - } - langOptions = map mkOption $ toList appLanguages - return $ mkOptionList langOptions - -instance RenderMessage UniWorX WeekDay where - renderMessage _ ls wDay = pack . fst $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7) - -newtype ShortWeekDay = ShortWeekDay { longWeekDay :: WeekDay } - -instance RenderMessage UniWorX ShortWeekDay where - renderMessage _ ls (ShortWeekDay wDay) = pack . snd $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7) - -instance Default DateTimeFormatter where - def = mkDateTimeFormatter (getTimeLocale' []) def appTZ - - --- Access Control -newtype InvalidAuthTag = InvalidAuthTag Text - deriving (Eq, Ord, Show, Read, Generic, Typeable) -instance Exception InvalidAuthTag - - -data AccessPredicate - = APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) - | APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Handler AuthResult) - | APDB (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend Handler AuthResult) - -class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where - evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult - -instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where - evalAccessPred aPred aid r w = liftHandler $ case aPred of - (APPure p) -> runReader (p aid r w) <$> getMsgRenderer - (APHandler p) -> p aid r w - (APDB p) -> runDBRead $ p aid r w - -instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend backend) => MonadAP (ReaderT backend m) where - evalAccessPred aPred aid r w = mapReaderT liftHandler . withReaderT (SqlReadBackend . projectBackend) $ case aPred of - (APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer - (APHandler p) -> lift $ p aid r w - (APDB p) -> p aid r w - - -orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult -orAR _ Authorized _ = Authorized -orAR _ _ Authorized = Authorized -orAR _ AuthenticationRequired _ = AuthenticationRequired -orAR _ _ AuthenticationRequired = AuthenticationRequired -orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y --- and -andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y -andAR _ reason@(Unauthorized _) _ = reason -andAR _ _ reason@(Unauthorized _) = reason -andAR _ Authorized other = other -andAR _ AuthenticationRequired _ = AuthenticationRequired - -notAR :: RenderMessage UniWorX msg => MsgRenderer -> msg -> AuthResult -> AuthResult -notAR _ _ (Unauthorized _) = Authorized -notAR _ _ AuthenticationRequired = AuthenticationRequired -notAR mr msg Authorized = Unauthorized . render mr . MsgUnauthorizedNot $ render mr msg - -trueAR, falseAR :: MsgRendererS UniWorX -> AuthResult -trueAR = const Authorized -falseAR = Unauthorized . ($ MsgUnauthorized) . render - -trueAP, falseAP :: AccessPredicate -trueAP = APPure . const . const . const $ trueAR <$> ask -falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness - - -data AuthContext = AuthContext - { authCtxAuth :: Maybe UserId - , authCtxBearer :: Maybe (BearerToken UniWorX) - , authActiveTags :: AuthTagActive - } deriving (Eq, Read, Show, Generic, Typeable) - deriving anyclass (Hashable, Binary) - -getAuthContext :: forall m. - ( MonadHandler m - , HandlerSite m ~ UniWorX - , MonadCatch m - ) - => m AuthContext -getAuthContext = do - authCtx <- AuthContext - <$> maybeAuthId - <*> runMaybeT (exceptTMaybe askBearerUnsafe) - <*> (fromMaybe def <$> lookupSessionJson SessionActiveAuthTags) - - $logDebugS "getAuthContext" $ tshow authCtx - - return authCtx - - -askBearerUnsafe :: forall m. - ( MonadHandler m - , HandlerSite m ~ UniWorX - , MonadCatch m - ) - => ExceptT AuthResult m (BearerToken UniWorX) --- | This performs /no/ meaningful validation of the `BearerToken` --- --- Use `requireBearerToken` or `maybeBearerToken` instead -askBearerUnsafe = $cachedHere $ do - bearer <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askBearer - catch (decodeBearer bearer) $ \case - BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired - BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted - other -> do - $logWarnS "AuthToken" $ tshow other - throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid - -validateBearer :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> ReaderT SqlReadBackend Handler AuthResult -validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateBearer' mAuthId' route' isWrite' token' - where - validateBearer' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult (ReaderT SqlReadBackend Handler) AuthResult - validateBearer' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do - guardMExceptT (maybe True (HashSet.member route) bearerRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute) - - bearerAuthority' <- flip foldMapM bearerAuthority $ \case - Left tVal - | JSON.Success groupName <- JSON.fromJSON tVal -> maybeT (throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . hoist lift $ do - Entity _ UserGroupMember{..} <- MaybeT . getBy $ UniquePrimaryUserGroupMember groupName Active - return $ Set.singleton userGroupMemberUser - | otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue - Right uid -> return $ Set.singleton uid - - let - -- Prevent infinite loops - noTokenAuth :: AuthDNF -> AuthDNF - noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar - - guardMExceptT (not $ Set.null bearerAuthority') $ unauthorizedI MsgUnauthorizedTokenInvalidNoAuthority - - forM_ bearerAuthority' $ \uid -> do - User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get uid - guardMExceptT (Just bearerIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired) - - authorityVal <- do - dnf <- either throwM return $ routeAuthTags route - fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just uid) route isWrite - guardExceptT (is _Authorized authorityVal) authorityVal - - whenIsJust bearerAddAuth $ \addDNF -> do - $logDebugS "validateToken" $ tshow addDNF - additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth addDNF) mAuthId route isWrite - guardExceptT (is _Authorized additionalVal) additionalVal - - return Authorized - -maybeBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => m (Maybe (BearerToken UniWorX)) -maybeBearerToken = runMaybeT $ catchIfMaybeT cPred requireBearerToken - where - cPred err = any ($ err) - [ is $ _HCError . _PermissionDenied - , is $ _HCError . _NotAuthenticated - ] - -requireBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (BearerToken UniWorX) -requireBearerToken = liftHandler $ do - bearer <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askBearerUnsafe - mAuthId <- maybeAuthId - currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute - isWrite <- isWriteRequest currentRoute - guardAuthResult <=< runDBRead $ validateBearer mAuthId currentRoute isWrite bearer - return bearer - -requireCurrentBearerRestrictions :: forall a m. - ( MonadHandler m - , HandlerSite m ~ UniWorX - , FromJSON a - , ToJSON a - ) - => m (Maybe a) -requireCurrentBearerRestrictions = runMaybeT $ do - bearer <- requireBearerToken - route <- MaybeT getCurrentRoute - hoistMaybe $ bearer ^? _bearerRestrictionIx route - -maybeCurrentBearerRestrictions :: forall a m. - ( MonadHandler m - , HandlerSite m ~ UniWorX - , MonadCatch m - , FromJSON a - , ToJSON a - ) - => m (Maybe a) -maybeCurrentBearerRestrictions = runMaybeT $ do - bearer <- MaybeT maybeBearerToken - route <- MaybeT getCurrentRoute - hoistMaybe $ bearer ^? _bearerRestrictionIx route - -isDryRun :: forall m. - ( MonadHandler m - , HandlerSite m ~ UniWorX - , MonadCatch m - ) - => m Bool -isDryRun = $cachedHere $ orM - [ hasGlobalPostParam PostDryRun - , hasGlobalGetParam GetDryRun - , and2M bearerDryRun bearerRequired - ] - where - bearerDryRun = has (_Just . _Object . ix "dry-run") <$> maybeCurrentBearerRestrictions @Value - bearerRequired = maybeT (return True) . catchIfMaybeT cPred . liftHandler $ do - mAuthId <- maybeAuthId - currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute - isWrite <- isWriteRequest currentRoute - - let noTokenAuth :: AuthDNF -> AuthDNF - noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar - - dnf <- either throwM return $ routeAuthTags currentRoute - guardAuthResult <=< fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) mAuthId currentRoute isWrite - - return False - - cPred err = any ($ err) - [ is $ _HCError . _PermissionDenied - , is $ _HCError . _NotAuthenticated - ] - - -tagAccessPredicate :: AuthTag -> AccessPredicate -tagAccessPredicate AuthFree = trueAP -tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of - -- Courses: access only to school admins - CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do - E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserFunctionSchool - E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId - E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) - return Authorized - -- Allocations: access only to school admins - AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do - E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserFunctionSchool - E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId - E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin - E.&&. allocation E.^. AllocationTerm E.==. E.val tid - E.&&. allocation E.^. AllocationSchool E.==. E.val ssh - E.&&. allocation E.^. AllocationShorthand E.==. E.val ash - guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) - return Authorized - -- Schools: access only to school admins - SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] - guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) - return Authorized - -- other routes: access to any admin is granted here - _other -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] [] - guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) - return Authorized -tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of - CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasUsers <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do - E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId - E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId - - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. exam E.^. ExamName E.==. E.val examn - - E.where_ $ examOfficeExamResultAuth (E.val authId) examResult - guardMExceptT hasUsers (unauthorizedI MsgUnauthorizedExamExamOffice) - return Authorized - EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasUsers <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do - E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam - - E.where_ $ eexam E.^. ExternalExamTerm E.==. E.val tid - E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh - E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen - E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn - - E.where_ $ examOfficeExternalExamResultAuth (E.val authId) eexamResult - guardMExceptT hasUsers $ unauthorizedI MsgUnauthorizedExternalExamExamOffice - return Authorized - CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isExamOffice <- lift . existsBy $ UniqueUserFunction authId ssh SchoolExamOffice - guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedExamExamOffice - return Authorized - _other -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] - guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice) - return Authorized -tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of - ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation - return Authorized - CourseR _ ssh _ _ -> $cachedHereBinary(mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation - return Authorized - _other -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation] - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation - return Authorized -tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route of - AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin - return Authorized - CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin - return Authorized - _other -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation] - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin - return Authorized -tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ - lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe -tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of - AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do - myUid <- maybeExceptT AuthenticationRequired $ return mAuthId - uid <- decrypt cID - otherSchoolsFunctions <- lift . $cachedHereBinary uid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid] [] - mySchools <- lift . $cachedHereBinary myUid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. myUid, UserFunctionFunction ==. SchoolAdmin] [] - guardMExceptT (otherSchoolsFunctions `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation) - return Authorized - r -> $unsupportedAuthPredicate AuthNoEscalation r -tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do - $logWarnS "AccessControl" ("deprecated route: " <> tshow r) - addMessageI Error MsgDeprecatedRoute - allow <- getsYesod $ view _appAllowDeprecated - return $ bool (Unauthorized "Deprecated Route") Authorized allow -tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do - $logWarnS "AccessControl" ("route in development: " <> tshow r) -#ifdef DEVELOPMENT - return Authorized -#else - return $ Unauthorized "Route under development" -#endif -tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of - CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isLecturer <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` lecturer) -> do - E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse - E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer) - return Authorized - AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do - E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse - E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse - E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation - E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId - E.&&. allocation E.^. AllocationTerm E.==. E.val tid - E.&&. allocation E.^. AllocationSchool E.==. E.val ssh - E.&&. allocation E.^. AllocationShorthand E.==. E.val ash - guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedAllocationLecturer - return Authorized - EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isLecturer <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` staff) -> do - E.on $ eexam E.^. ExternalExamId E.==. staff E.^. ExternalExamStaffExam - E.where_ $ staff E.^. ExternalExamStaffUser E.==. E.val authId - E.&&. eexam E.^. ExternalExamTerm E.==. E.val tid - E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh - E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen - E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn - guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedExternalExamLecturer - return Authorized - -- lecturer for any school will do - _ -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] [] - return Authorized -tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - resList <- $cachedHereBinary mAuthId . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do - E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId - return (course E.^. CourseId, sheet E.^. SheetId) - let - resMap :: Map CourseId (Set SheetId) - resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ] - case route of - CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do - sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - Submission{..} <- MaybeT . lift $ get sid - guard $ Just authId == submissionRatingBy - return Authorized - CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do - Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn - guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid) - return Authorized - CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do - Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - guard $ cid `Set.member` Map.keysSet resMap - return Authorized - _ -> do - guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) - return Authorized -tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of - CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do - E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId - E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId - E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. exam E.^. ExamName E.==. E.val examn - guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector - return Authorized - CourseR tid ssh csh _ -> $cachedHereBinary (tid, ssh, csh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam - E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector - return Authorized - r -> $unsupportedAuthPredicate AuthExamCorrector r -tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do - E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId - E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId - E.where_ $ tutor E.^. TutorUser E.==. E.val authId - return (course E.^. CourseId, tutorial E.^. TutorialId) - let - resMap :: Map CourseId (Set TutorialId) - resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ] - case route of - CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do - Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - Entity tutid _ <- $cachedHereBinary (cid, tutn) . MaybeT . lift . getBy $ UniqueTutorial cid tutn - guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid) - return Authorized - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do - Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - guard $ cid `Set.member` Map.keysSet resMap - return Authorized - _ -> do - guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) - return Authorized -tagAccessPredicate AuthTutorControl = APDB $ \_ route _ -> case route of - CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do - Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn - guard tutorialTutorControlled - return Authorized - r -> $unsupportedAuthPredicate AuthTutorControl r -tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route of - CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do - course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn - smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - groups <- $cachedHereBinary cID . lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionUser) -> do - E.on $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. submissionUser E.^. SubmissionUserUser - E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smId - return $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup - unless (Set.null groups || isn't _RegisteredGroups sheetGrouping) $ do - uid <- hoistMaybe mAuthId - guardM . lift $ exists [SubmissionGroupUserUser ==. uid, SubmissionGroupUserSubmissionGroup <-. Set.toList groups] - return Authorized - CSheetR tid ssh csh sheetn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetSubmissionGroup) $ do - course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{..} <- $cachedHereBinary (course, sheetn) . MaybeT . getBy $ CourseSheet course sheetn - when (is _RegisteredGroups sheetGrouping) $ do - uid <- hoistMaybe mAuthId - guardM . lift . E.selectExists . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do - E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId - E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val course - E.&&. submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid - - return Authorized - r -> $unsupportedAuthPredicate AuthSubmissionGroup r -tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of - CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do - course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn - cTime <- liftIO getCurrentTime - registration <- case mAuthId of - Just uid -> $cachedHereBinary (eId, uid) . lift . getBy $ UniqueExamRegistration eId uid - Nothing -> return Nothing - - let visible = NTop examVisibleFrom <= NTop (Just cTime) - - case subRoute of - EShowR -> guard visible - EUsersR -> guard $ NTop examStart <= NTop (Just cTime) - && NTop (Just cTime) <= NTop examFinished - ERegisterR - | is _Nothing registration - -> guard $ visible - && NTop examRegisterFrom <= NTop (Just cTime) - && NTop (Just cTime) <= NTop examRegisterTo - | otherwise - -> guard $ visible - && NTop (Just cTime) <= NTop examDeregisterUntil - ERegisterOccR occn -> do - occId <- hoistMaybe <=< $cachedHereBinary (eId, occn) . lift . getKeyBy $ UniqueExamOccurrence eId occn - if - | (registration >>= examRegistrationOccurrence . entityVal) == Just occId - -> guard $ visible - && NTop (Just cTime) <= NTop examDeregisterUntil - | otherwise - -> guard $ visible - && NTop examRegisterFrom <= NTop (Just cTime) - && NTop (Just cTime) <= NTop examRegisterTo - ECorrectR -> guard $ NTop (Just cTime) >= NTop examStart - && NTop (Just cTime) <= NTop examFinished - _ -> return () - - return Authorized - - CTutorialR tid ssh csh tutn TRegisterR -> maybeT (unauthorizedI MsgUnauthorizedTutorialTime) $ do - now <- liftIO getCurrentTime - course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity tutId Tutorial{..} <- $cachedHereBinary (course, tutn) . MaybeT . getBy $ UniqueTutorial course tutn - registered <- case mAuthId of - Just uid -> $cachedHereBinary (tutId, uid) . lift . existsBy $ UniqueTutorialParticipant tutId uid - Nothing -> return False - - if - | not registered - , maybe False (now >=) tutorialRegisterFrom - , maybe True (now <=) tutorialRegisterTo - -> return Authorized - | registered - , maybe True (now <=) tutorialDeregisterUntil - -> return Authorized - | otherwise - -> mzero - - CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do - cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _sid Sheet{..} <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn - cTime <- liftIO getCurrentTime - let - visible = NTop sheetVisibleFrom <= NTop (Just cTime) - active = NTop sheetActiveFrom <= NTop (Just cTime) && NTop (Just cTime) <= NTop sheetActiveTo - marking = NTop (Just cTime) > NTop sheetActiveTo - - guard visible - - case subRoute of - -- Single Files - SFileR SheetExercise _ -> guard $ NTop sheetActiveFrom <= NTop (Just cTime) - SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom - SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom - SFileR _ _ -> mzero - -- Archives of SheetFileType - SZipR SheetExercise -> guard $ NTop sheetActiveFrom <= NTop (Just cTime) - SZipR SheetHint -> guard $ maybe False (<= cTime) sheetHintFrom - SZipR SheetSolution -> guard $ maybe False (<= cTime) sheetSolutionFrom - SZipR _ -> mzero - -- Submissions - SubmissionNewR -> guard active - SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change; this is assumed in Corrections.assignHandler - SubmissionR _ SubAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change - SubmissionR _ _ -> guard active - _ -> return () - - return Authorized - - CourseR tid ssh csh (MaterialR mnm _) -> maybeT (unauthorizedI MsgUnauthorizedMaterialTime) $ do - cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _mid Material{materialVisibleFrom} <- $cachedHereBinary (cid, mnm) . MaybeT . getBy $ UniqueMaterial cid mnm - cTime <- liftIO getCurrentTime - let visible = NTop materialVisibleFrom <= NTop (Just cTime) - guard visible - return Authorized - - CourseR tid ssh csh CRegisterR -> do - now <- liftIO getCurrentTime - mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh - registered <- case (mbc,mAuthId) of - (Just (Entity cid _), Just uid) -> $cachedHereBinary (uid, cid) $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive] - _ -> return False - case mbc of - (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo})) - | not registered - , maybe False (now >=) courseRegisterFrom -- Nothing => no registration allowed - , maybe True (now <=) courseRegisterTo -> return Authorized - (Just (Entity cid Course{courseDeregisterUntil})) - | registered - -> maybeT (unauthorizedI MsgUnauthorizedCourseRegistrationTime) $ do - guard $ maybe True (now <=) courseDeregisterUntil - forM_ mAuthId $ \uid -> do - exams <- lift . E.select . E.from $ \exam -> do - E.where_ . E.exists . E.from $ \examRegistration -> - E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId - E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid - E.where_ $ exam E.^. ExamCourse E.==. E.val cid - return $ exam E.^. ExamDeregisterUntil - forM_ exams $ \(E.Value deregUntil) -> - guard $ NTop (Just now) <= NTop deregUntil - - tutorials <- lift . E.select . E.from $ \tutorial -> do - E.where_ . E.exists . E.from $ \tutorialParticipant -> - E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId - E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid - E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid - return $ tutorial E.^. TutorialDeregisterUntil - forM_ tutorials $ \(E.Value deregUntil) -> - guard $ NTop (Just now) <= NTop deregUntil - return Authorized - _other -> unauthorizedI MsgUnauthorizedCourseRegistrationTime - - CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do - Entity course Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course - allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation - - case allocation of - Nothing -> do - cTime <- liftIO getCurrentTime - guard $ maybe False (cTime >=) courseRegisterFrom - guard $ maybe True (cTime <=) courseRegisterTo - Just Allocation{..} -> do - cTime <- liftIO getCurrentTime - guard $ NTop allocationRegisterFrom <= NTop (Just cTime) - guard $ NTop (Just cTime) <= NTop allocationRegisterTo - - return Authorized - - AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do - -- Checks `registerFrom` and `registerTo`, override as further routes become available - now <- liftIO getCurrentTime - Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash - guard $ NTop allocationRegisterFrom <= NTop (Just now) - guard $ NTop (Just now) <= NTop allocationRegisterTo - return Authorized - - MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do - smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId - cTime <- NTop . Just <$> liftIO getCurrentTime - guard $ NTop systemMessageFrom <= cTime - && NTop systemMessageTo >= cTime - return Authorized - - MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do - smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId - cTime <- NTop . Just <$> liftIO getCurrentTime - guard $ NTop systemMessageFrom <= cTime - && NTop systemMessageTo >= cTime - return Authorized - - CNewsR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsTime) $ do - nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - CourseNews{courseNewsVisibleFrom} <- $cachedHereBinary nId . MaybeT $ get nId - cTime <- NTop . Just <$> liftIO getCurrentTime - guard $ NTop courseNewsVisibleFrom <= cTime - return Authorized - - r -> $unsupportedAuthPredicate AuthTime r -tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of - CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do - course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course - allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation - - case allocation of - Nothing -> return () - Just Allocation{..} -> do - cTime <- liftIO getCurrentTime - guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime) - when isWrite $ - guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo - - return Authorized - - AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do - -- Checks `registerFrom` and `registerTo`, override as further routes become available - now <- liftIO getCurrentTime - Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash - guard $ NTop allocationStaffAllocationFrom <= NTop (Just now) - guard $ NTop (Just now) <= NTop allocationStaffAllocationTo - return Authorized - - r -> $unsupportedAuthPredicate AuthStaffTime r -tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of - CourseR tid ssh csh CRegisterR -> do - now <- liftIO getCurrentTime - mba <- mbAllocation tid ssh csh - case mba of - Nothing -> return Authorized - Just (cid, Allocation{..}) -> do - registered <- case mAuthId of - Just uid -> $cachedHereBinary (uid, cid) . existsBy $ UniqueParticipant uid cid - _ -> return False - if - | not registered - , NTop allocationRegisterByCourse >= NTop (Just now) - -> unauthorizedI MsgUnauthorizedAllocatedCourseRegister - | registered - , NTop (Just now) >= NTop allocationOverrideDeregister - -> unauthorizedI MsgUnauthorizedAllocatedCourseDeregister - | otherwise - -> return Authorized - - CourseR tid ssh csh CAddUserR -> do - now <- liftIO getCurrentTime - mba <- mbAllocation tid ssh csh - case mba of - Just (_, Allocation{..}) - | NTop allocationRegisterByStaffTo <= NTop (Just now) - || NTop allocationRegisterByStaffFrom >= NTop (Just now) - -> unauthorizedI MsgUnauthorizedAllocatedCourseRegister - _other -> return Authorized - - CourseR tid ssh csh CDeleteR -> do - now <- liftIO getCurrentTime - mba <- mbAllocation tid ssh csh - case mba of - Just (_, Allocation{..}) - | NTop allocationRegisterByStaffTo <= NTop (Just now) - || NTop allocationRegisterByStaffFrom >= NTop (Just now) - -> unauthorizedI MsgUnauthorizedAllocatedCourseDelete - _other -> return Authorized - - r -> $unsupportedAuthPredicate AuthAllocationTime r - where - mbAllocation tid ssh csh = $cachedHereBinary (tid, ssh, csh) . runMaybeT $ do - cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid - (cid,) <$> MaybeT (get allocationCourseAllocation) -tagAccessPredicate AuthCourseTime = APDB $ \_mAuthId route _ -> case route of - CourseR tid ssh csh _ -> exceptT return return $ do - now <- liftIO getCurrentTime - courseVisible <- $cachedHereBinary (tid, ssh, csh) . lift . E.selectExists . E.from $ \course -> do - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. courseIsVisible now course Nothing - guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime) - return Authorized - r -> $unsupportedAuthPredicate AuthCourseTime r -tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of - CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do - E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse - E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId - E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) - return Authorized - r -> $unsupportedAuthPredicate AuthCourseRegistered r -tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of - CTutorialR tid ssh csh tutn _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isRegistered <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do - E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial - E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. tutorial E.^. TutorialName E.==. E.val tutn - guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) - return Authorized - CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do - E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial - E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) - return Authorized - r -> $unsupportedAuthPredicate AuthTutorialRegistered r -tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ route _ -> case route of - CExamR tid ssh csh examn _ -> exceptT return return $ do - isOccurrenceRegistration <- $cachedHereBinary (tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam) -> do - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. exam E.^. ExamName E.==. E.val examn - E.&&. exam E.^. ExamOccurrenceRule E.==. E.val ExamRoomFifo - guardMExceptT isOccurrenceRegistration (unauthorizedI MsgUnauthorizedExamOccurrenceRegistration) - return Authorized - r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistration r -tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \mAuthId route _ -> case route of - CExamR tid ssh csh examn (ERegisterOccR occn) -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn, occn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration `E.InnerJoin` examOccurrence) -> do - E.on $ E.just (examOccurrence E.^. ExamOccurrenceId) E.==. examRegistration E.^. ExamRegistrationOccurrence - E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId - E.&&. examOccurrence E.^. ExamOccurrenceName E.==. E.val occn - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. exam E.^. ExamName E.==. E.val examn - guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) - return Authorized - CExamR tid ssh csh examn _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do - E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. exam E.^. ExamName E.==. E.val examn - E.&&. E.not_ (E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence) - guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) - return Authorized - CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do - E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. E.not_ (E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence) - guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) - return Authorized - r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistered r -tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of - CExamR tid ssh csh examn _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do - E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. exam E.^. ExamName E.==. E.val examn - guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredExam - return Authorized - CSheetR tid ssh csh shn _ -> exceptT return return $ do - requiredExam' <- $cachedHereBinary (tid, ssh, csh, shn) . lift . E.selectMaybe . E.from $ \(course `E.InnerJoin` sheet) -> do - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. sheet E.^. SheetName E.==. E.val shn - return $ sheet E.^. SheetRequireExamRegistration - requiredExam <- maybeMExceptT (unauthorizedI MsgUnauthorizedRegisteredExam) . return $ E.unValue <$> requiredExam' - whenIsJust requiredExam $ \eId -> do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isRegistered <- $cachedHereBinary (authId, eId) . lift . E.selectExists . E.from $ \examRegistration -> - E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId - E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val authId - guardMExceptT isRegistered $ unauthorizedI MsgUnauthorizedRegisteredExam - return Authorized - CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do - E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredAnyExam - return Authorized - r -> $unsupportedAuthPredicate AuthExamRegistered r -tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of - CExamR tid ssh csh examn _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do - E.on $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examResult E.^. ExamResultUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. exam E.^. ExamName E.==. E.val examn - hasPartResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart `E.InnerJoin` examPartResult) -> do - E.on $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId - E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. exam E.^. ExamName E.==. E.val examn - guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult) - return Authorized - EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasResult <- $cachedHereBinary (authId, tid, ssh, coursen, examn) . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do - E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam - E.where_ $ eexamResult E.^. ExternalExamResultUser E.==. E.val authId - E.&&. eexam E.^. ExternalExamTerm E.==. E.val tid - E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh - E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen - E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn - guardMExceptT hasResult $ unauthorizedI MsgUnauthorizedExternalExamResult - return Authorized - CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasResult <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do - E.on $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examResult E.^. ExamResultUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - hasPartResult <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart `E.InnerJoin` examPartResult) -> do - E.on $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId - E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult) - return Authorized - r -> $unsupportedAuthPredicate AuthExamRegistered r -tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case route of - AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegistered) $ do - uid <- hoistMaybe mAuthId - aId <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getKeyBy $ TermSchoolAllocationShort tid ssh ash - void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid - return Authorized - r -> $unsupportedAuthPredicate AuthAllocationRegistered r -tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of - CNewsR tid ssh csh cID _ -> maybeT (unauthorizedI MsgUnauthorizedParticipantSelf) $ do - nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId - if | courseNewsParticipantsOnly -> do - uid <- hoistMaybe mAuthId - exceptT return (const mzero) . hoist lift $ isCourseParticipant tid ssh csh uid True - | otherwise - -> return Authorized - - CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do - participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID - isCourseParticipant tid ssh csh participant False - unauthorizedI MsgUnauthorizedParticipant - - r -> $unsupportedAuthPredicate AuthParticipant r - - where - isCourseParticipant tid ssh csh participant onlyActive = do - let - authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult (ReaderT SqlReadBackend Handler) () - authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from - -- participant is currently registered - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do - E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse - E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - when onlyActive $ - E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - -- participant has at least one submission - unless onlyActive $ - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do - E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission - E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is member of a submissionGroup - unless onlyActive $ - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do - E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup - E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse - E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is a sheet corrector - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do - E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is a tutorial user - unless onlyActive $ - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do - E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial - E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is tutor for this course - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do - E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial - E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutor E.^. TutorUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is exam corrector for this course - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do - E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is lecturer for this course - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do - E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse - E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant has an exam result for this course - unless onlyActive $ - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do - E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examResult E.^. ExamResultUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is registered for an exam for this course - unless onlyActive $ - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do - E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh -tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of - CourseR tid ssh csh (CUserR cID) -> maybeT (unauthorizedI MsgUnauthorizedApplicant) $ do - uid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - isApplicant <- isCourseApplicant tid ssh csh uid - guard isApplicant - return Authorized - - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedApplicantSelf) $ do - uid <- hoistMaybe mAuthId - isApplicant <- isCourseApplicant tid ssh csh uid - guard isApplicant - return Authorized - - r -> $unsupportedAuthPredicate AuthApplicant r - where - isCourseApplicant tid ssh csh uid = lift . $cachedHereBinary (uid, tid, ssh, csh) . E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do - E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse - E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh -tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of - CExamR tid ssh csh examn (ERegisterOccR occn) -> maybeT (unauthorizedI MsgExamOccurrenceNoCapacity) $ do - cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - eid <- $cachedHereBinary (cid, examn) . MaybeT . getKeyBy $ UniqueExam cid examn - Entity occId ExamOccurrence{..} <- $cachedHereBinary (eid, occn) . MaybeT . getBy $ UniqueExamOccurrence eid occn - registered <- $cachedHereBinary occId . lift $ fromIntegral <$> count [ ExamRegistrationOccurrence ==. Just occId, ExamRegistrationExam ==. eid ] - guard $ examOccurrenceCapacity > registered - return Authorized - CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do - cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity tutId Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn - registered <- $cachedHereBinary tutId . lift $ count [ TutorialParticipantTutorial ==. tutId ] - guard $ NTop tutorialCapacity > NTop (Just registered) - return Authorized - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do - Entity cid Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - registered <- $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] - guard $ NTop courseCapacity > NTop (Just registered) - return Authorized - r -> $unsupportedAuthPredicate AuthCapacity r -tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of - CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do - cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn - case (tutorialRegGroup, mAuthId) of - (Nothing, _) -> return Authorized - (_, Nothing) -> return AuthenticationRequired - (Just rGroup, Just uid) -> do - hasOther <- $cachedHereBinary (uid, rGroup) . lift . E.selectExists . E.from $ \(tutorial `E.InnerJoin` participant) -> do - E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial - E.&&. tutorial E.^. TutorialCourse E.==. E.val tutorialCourse - E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup) - E.&&. participant E.^. TutorialParticipantUser E.==. E.val uid - guard $ not hasOther - return Authorized - r -> $unsupportedAuthPredicate AuthRegisterGroup r -tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> case route of - EExamListR -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do - E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam - E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId - guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty - return Authorized - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do - -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ] - assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do - E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet - E.where_ $ sheet E.^. SheetCourse E.==. E.val cid - return Authorized - r -> $unsupportedAuthPredicate AuthEmpty r -tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do - Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - guard courseMaterialFree - return Authorized - r -> $unsupportedAuthPredicate AuthMaterials r -tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of - CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do - sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid - return Authorized - r -> $unsupportedAuthPredicate AuthOwner r -tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \mAuthId route _ -> case route of - CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . exceptT return return $ do - Entity shId Sheet{..} <- maybeTMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) $ do - cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh - MaybeT . $cachedHereBinary (cid, shn) . getBy $ CourseSheet cid shn - if | sheetAllowNonPersonalisedSubmission -> return Authorized - | otherwise -> do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - flip guardMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) <=< $cachedHereBinary (shId, authId) . lift $ - E.selectExists . E.from $ \psFile -> - E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. E.val shId - E.&&. psFile E.^. PersonalisedSheetFileUser E.==. E.val authId - E.&&. E.not_ (E.isNothing $ psFile E.^. PersonalisedSheetFileContent) -- directories don't count - return Authorized - r -> $unsupportedAuthPredicate AuthPersonalisedSheetFiles r -tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of - CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do - sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - sub <- MaybeT $ get sid - guard $ submissionRatingDone sub - return Authorized - r -> $unsupportedAuthPredicate AuthRated r -tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of - CSheetR tid ssh csh shn _ -> $cachedHereBinary (tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do - Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn - guard $ is _Just submissionModeUser - return Authorized - r -> $unsupportedAuthPredicate AuthUserSubmissions r -tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of - CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do - Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn - guard submissionModeCorrector - return Authorized - r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r -tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ do - referencedUser' <- case route of - AdminUserR cID -> return $ Left cID - AdminUserDeleteR cID -> return $ Left cID - AdminHijackUserR cID -> return $ Left cID - UserNotificationR cID -> return $ Left cID - UserPasswordR cID -> return $ Left cID - CourseR _ _ _ (CUserR cID) -> return $ Left cID - CApplicationR _ _ _ cID _ -> do - appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID - CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId - return $ Right courseApplicationUser - _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route - referencedUser <- case referencedUser' of - Right uid -> return uid - Left cID -> catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID - case mAuthId of - Just uid - | uid == referencedUser -> return Authorized - Nothing -> return AuthenticationRequired - _other -> unauthorizedI MsgUnauthorizedSelf -tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do - referencedUser <- case route of - AdminUserR cID -> return cID - AdminUserDeleteR cID -> return cID - AdminHijackUserR cID -> return cID - UserNotificationR cID -> return cID - UserPasswordR cID -> return cID - CourseR _ _ _ (CUserR cID) -> return cID - _other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route - referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser - maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do - User{..} <- MaybeT $ get referencedUser' - guard $ userAuthentication == AuthLDAP - return Authorized -tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ do - referencedUser <- case route of - AdminUserR cID -> return cID - AdminUserDeleteR cID -> return cID - AdminHijackUserR cID -> return cID - UserNotificationR cID -> return cID - UserPasswordR cID -> return cID - CourseR _ _ _ (CUserR cID) -> return cID - _other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route - referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser - maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do - User{..} <- MaybeT $ get referencedUser' - guard $ is _AuthPWHash userAuthentication - return Authorized -tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of - MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do - smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId - let isAuthenticated = isJust mAuthId - guard $ not systemMessageAuthenticatedOnly || isAuthenticated - return Authorized - MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do - smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId - let isAuthenticated = isJust mAuthId - guard $ not systemMessageAuthenticatedOnly || isAuthenticated - return Authorized - r -> $unsupportedAuthPredicate AuthAuthentication r -tagAccessPredicate AuthRead = APPure $ \_ _ isWrite -> do - MsgRenderer mr <- ask - return $ bool Authorized (Unauthorized $ mr MsgUnauthorizedWrite) isWrite -tagAccessPredicate AuthWrite = APPure $ \_ _ isWrite -> do - MsgRenderer mr <- ask - return $ bool (Unauthorized $ mr MsgUnauthorized) Authorized isWrite - - -authTagSpecificity :: AuthTag -> AuthTag -> Ordering --- ^ Heuristic for which `AuthTag`s to evaluate first -authTagSpecificity = comparing $ NTop . flip findIndex eqClasses . elem - where - eqClasses :: [[AuthTag]] - -- ^ Constructors of `AuthTag` ordered (increasing) by execution order - eqClasses = - [ [ AuthFree, AuthDeprecated, AuthDevelopment ] -- Route wide - , [ AuthRead, AuthWrite, AuthToken ] -- Request wide - , [ AuthAdmin ] -- Site wide - , [ AuthLecturer, AuthCourseRegistered, AuthParticipant, AuthCourseTime, AuthTime, AuthMaterials, AuthUserSubmissions, AuthCorrectorSubmissions, AuthCapacity, AuthEmpty ] ++ [ AuthSelf, AuthNoEscalation ] ++ [ AuthAuthentication ] -- Course/User/SystemMessage wide - , [ AuthCorrector ] ++ [ AuthTutor ] ++ [ AuthTutorialRegistered, AuthRegisterGroup ] -- Tutorial/Material/Sheet wide - , [ AuthOwner, AuthRated ] -- Submission wide - ] - -defaultAuthDNF :: AuthDNF -defaultAuthDNF = PredDNF $ Set.fromList - [ impureNonNull . Set.singleton $ PLVariable AuthAdmin - , impureNonNull . Set.singleton $ PLVariable AuthToken - ] - -routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF --- ^ DNF up to entailment: --- --- > (A_1 && A_2 && ...) OR' B OR' ... --- --- > A OR' B := ((A |- B) ==> A) && (A || B) -routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms defaultAuthDNF) . routeAttrs - where - partition' :: Set (Set AuthLiteral) -> Text -> Either InvalidAuthTag (Set (Set AuthLiteral)) - partition' prev t - | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t) - = if - | oany (authTags `Set.isSubsetOf`) prev - -> Right prev - | otherwise - -> Right . Set.insert authTags $ Set.filter (not . (`Set.isSubsetOf` authTags)) prev - | otherwise - = Left $ InvalidAuthTag t - -evalAuthTags :: forall m. MonadAP m => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult --- ^ `tell`s disabled predicates, identified as pivots -evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite - = do - mr <- getMsgRenderer - let - authVarSpecificity = authTagSpecificity `on` plVar - authDNF = sortBy (authVarSpecificity `on` maximumBy authVarSpecificity . impureNonNull) $ map (sortBy authVarSpecificity) authDNF' - - authTagIsInactive = not . authTagIsActive - - evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult - evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite - where - evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do - $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite') - evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite' - - evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult - evalAuthLiteral PLVariable{..} = evalAuthTag plVar - evalAuthLiteral PLNegated{..} = notAR mr plVar <$> evalAuthTag plVar - - orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult - orAR' = shortCircuitM (is _Authorized) (orAR mr) - andAR' = shortCircuitM (is _Unauthorized) (andAR mr) - - evalDNF :: [[AuthLiteral]] -> WriterT (Set AuthTag) m AuthResult - evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthLiteral aTag) (return $ trueAR mr) ats) (return $ falseAR mr) - - $logDebugS "evalAuthTags" . tshow . (route, isWrite, ) $ map (map $ id &&& authTagIsActive . plVar) authDNF - - result <- evalDNF $ filter (all $ authTagIsActive . plVar) authDNF - - unless (is _Authorized result) . forM_ (filter (any $ authTagIsInactive . plVar) authDNF) $ \conj -> - whenM (allM conj (\aTag -> (return . not . authTagIsActive $ plVar aTag) `or2M` (not . is _Unauthorized <$> evalAuthLiteral aTag))) $ do - let pivots = filter (authTagIsInactive . plVar) conj - whenM (allM pivots $ fmap (is _Authorized) . evalAuthLiteral) $ do - let pivots' = plVar <$> pivots - $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots'}|] - tell $ Set.fromList pivots' - - return result - -evalAccessFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult -evalAccessFor mAuthId route isWrite = do - dnf <- either throwM return $ routeAuthTags route - fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite - -evalAccessForDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult -evalAccessForDB = evalAccessFor - -evalAccessWith :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult -evalAccessWith assumptions route isWrite = do - mAuthId <- liftHandler maybeAuthId - tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags - dnf <- either throwM return $ routeAuthTags route - let dnf' = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) $ Just dnf - case dnf' of - Nothing -> return Authorized - Just dnf'' -> do - (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf'' mAuthId route isWrite - result <$ tellSessionJson SessionInactiveAuthTags deactivated - -evalAccessWithDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult -evalAccessWithDB = evalAccessWith - -evalAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult -evalAccess = evalAccessWith [] - -evalAccessDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend backend) => Route UniWorX -> Bool -> ReaderT backend m AuthResult -evalAccessDB = evalAccess - --- | Check whether the current user is authorized by `evalAccess` for the given route --- Convenience function for a commonly used code fragment -hasAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m Bool -hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite - --- | Check whether the current user is authorized by `evalAccess` to read from the given route --- Convenience function for a commonly used code fragment -hasReadAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool -hasReadAccessTo = flip hasAccessTo False - --- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route --- Convenience function for a commonly used code fragment -hasWriteAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool -hasWriteAccessTo = flip hasAccessTo True - -wouldHaveAccessTo :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) - => [(AuthTag, Bool)] -- ^ Assumptions - -> Route UniWorX - -> Bool - -> m Bool -wouldHaveAccessTo assumptions route isWrite = (== Authorized) <$> evalAccessWith assumptions route isWrite - -wouldHaveReadAccessTo, wouldHaveWriteAccessTo - :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) - => [(AuthTag, Bool)] -- ^ Assumptions - -> Route UniWorX - -> m Bool -wouldHaveReadAccessTo assumptions route = wouldHaveAccessTo assumptions route False -wouldHaveWriteAccessTo assumptions route = wouldHaveAccessTo assumptions route True - -wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff - :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) - => [(AuthTag, Bool)] -- ^ Assumptions - -> Route UniWorX - -> m Bool -wouldHaveReadAccessToIff assumptions route = and2M (not <$> hasReadAccessTo route) $ wouldHaveReadAccessTo assumptions route -wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo route) $ wouldHaveWriteAccessTo assumptions route - --- | Conditional redirect that hides the URL if the user is not authorized for the route -redirectAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a -redirectAccess url = do - -- must hide URL if not authorized - access <- evalAccess url False - case access of - Authorized -> redirect url - _ -> permissionDeniedI MsgUnauthorizedRedirect - -redirectAccessWith :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Status -> Route UniWorX -> m a -redirectAccessWith status url = do - -- must hide URL if not authorized - access <- evalAccess url False - case access of - Authorized -> redirectWith status url - _ -> permissionDeniedI MsgUnauthorizedRedirect - - --- | Verify that the currently logged in user is lecturer or corrector for at least one sheet for the given course -evalAccessCorrector :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) - => TermId -> SchoolId -> CourseShorthand -> m AuthResult -evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False - - -data instance ButtonClass UniWorX - = BCIsButton - | BCDefault - | BCPrimary - | BCSuccess - | BCInfo - | BCWarning - | BCDanger - | BCLink - | BCMassInputAdd | BCMassInputDelete - deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) - deriving anyclass (Universe, Finite) - -instance PathPiece (ButtonClass UniWorX) where - toPathPiece BCIsButton = "btn" - toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass - fromPathPiece = flip List.lookup $ map (toPathPiece &&& id) universeF - -instance Button UniWorX ButtonSubmit where - btnClasses BtnSubmit = [BCIsButton, BCPrimary] - - - --- Please see the documentation for the Yesod typeclass. There are a number --- of settings which can be configured by overriding methods here. -instance Yesod UniWorX where - -- Controls the base of generated URLs. For more information on modifying, - -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot - approot = ApprootRequest $ \app req -> - case app ^. _appRoot of - Nothing -> getApprootText guessApproot app req - Just root -> root - - makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of - SessionStorageMemcachedSql sqlStore - -> mkBackend . stateSettings =<< ServerSession.createState sqlStore - SessionStorageAcid acidStore - | appServerSessionAcidFallback - -> mkBackend . stateSettings =<< ServerSession.createState acidStore - _other - -> return Nothing - where - cfg = JwtSession.ServerSessionJwtConfig - { sJwtJwkSet = appJSONWebKeySet - , sJwtStart = Nothing - , sJwtExpiration = appSessionTokenExpiration - , sJwtEncoding = appSessionTokenEncoding - , sJwtIssueBy = appInstanceID - , sJwtIssueFor = appClusterID - } - mkBackend :: forall sto. - ( ServerSession.SessionData sto ~ Map Text ByteString - , ServerSession.Storage sto - ) - => ServerSession.State sto -> IO (Maybe SessionBackend) - mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app) - stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto - stateSettings = ServerSession.setCookieName (toPathPiece CookieSession) . applyServerSessionSettings appServerSessionConfig - sameSite - | Just sameSiteStrict == cookieSameSite (getCookieSettings app CookieSession) - = strictSameSiteSessions - | Just sameSiteLax == cookieSameSite (getCookieSettings app CookieSession) - = laxSameSiteSessions - | otherwise - = id - notForBearer :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend) - notForBearer = fmap $ fmap notForBearer' - where notForBearer' :: SessionBackend -> SessionBackend - notForBearer' (SessionBackend load) - = let load' req - | aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req - , any (is _Just . W.extractBearerAuth) aHdrs - = return (mempty, const $ return []) - | otherwise - = load req - in SessionBackend load' - - maximumContentLength app _ = app ^. _appMaximumContentLength - - -- Yesod Middleware allows you to run code before and after each handler function. - -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. - -- Some users may also want to add the defaultCsrfMiddleware, which: - -- a) Sets a cookie with a CSRF token in it. - -- b) Validates that incoming write requests include that token in either a header or POST parameter. - -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware - -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. - yesodMiddleware = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware - where - dryRunMiddleware :: Handler a -> Handler a - dryRunMiddleware handler = do - dryRun <- isDryRun - if | dryRun -> do - hData <- ask - prevState <- readIORef (handlerState hData) - let - restoreSession = - modifyIORef (handlerState hData) $ - \hst -> hst { ghsSession = ghsSession prevState - , ghsCache = ghsCache prevState - , ghsCacheBy = ghsCacheBy prevState - } - site' = (rheSite $ handlerEnv hData) { appMemcached = Nothing } - handler' = local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheSite = site', rheChild = site' } }) handler - - addCustomHeader HeaderDryRun ("1" :: Text) - - handler' `finally` restoreSession - | otherwise -> handler - updateFavouritesMiddleware :: Handler a -> Handler a - updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do - route <- MaybeT getCurrentRoute - case route of -- update Course Favourites here - CourseR tid ssh csh _ -> do - void . lift . runDB . runMaybeT $ do - guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid ssh csh CShowR) False - lift . updateFavourites $ Just (tid, ssh, csh) - _other -> return () - normalizeRouteMiddleware :: Handler a -> Handler a - normalizeRouteMiddleware handler = (*> handler) . runMaybeT $ do - route <- MaybeT getCurrentRoute - (route', getAny -> changed) <- lift . runDB . runWriterT $ foldM (&) route routeNormalizers - when changed $ do - $logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|] - redirectWith movedPermanently301 route' - headerMessagesMiddleware :: Handler a -> Handler a - headerMessagesMiddleware handler = (handler `finally`) . runMaybeT $ do - isModal <- hasCustomHeader HeaderIsModal - dbTableShortcircuit <- hasCustomHeader HeaderDBTableShortcircuit - massInputShortcircuit <- hasCustomHeader HeaderMassInputShortcircuit - $logDebugS "headerMessagesMiddleware" $ tshow (isModal, dbTableShortcircuit, massInputShortcircuit) - guard $ or - [ isModal - , dbTableShortcircuit - , massInputShortcircuit - ] - - lift . bracketOnError getMessages (mapM_ addMessage') $ - addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode - observeYesodCacheSizeMiddleware :: Handler a -> Handler a - observeYesodCacheSizeMiddleware handler = handler `finally` observeYesodCacheSize - csrfMiddleware :: Handler a -> Handler a - csrfMiddleware handler = do - hasBearer <- is _Just <$> lookupBearerAuth - - if | hasBearer -> local (\HandlerData{..} -> HandlerData{ handlerRequest = handlerRequest { reqToken = Nothing }, .. }) handler - | otherwise -> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler - where - csrfSetCookieMiddleware' handler' = do - mcsrf <- reqToken <$> getRequest - whenIsJust mcsrf $ setRegisteredCookie CookieXSRFToken - handler' - storeBearerMiddleware :: Handler a -> Handler a - storeBearerMiddleware handler = do - askBearer >>= \case - Just (Jwt bs) -> setSessionBS (toPathPiece SessionBearer) bs - Nothing -> return () - - handler - - -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget` - defaultMessageWidget _title _body = error "defaultMessageWidget: undefined" - - errorHandler err = do - shouldEncrypt <- do - canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True - shouldEncrypt <- getsYesod $ view _appEncryptErrors - return $ shouldEncrypt && not canDecrypt - - sessErr <- bool return (_InternalError $ encodedSecretBox SecretBoxShort) shouldEncrypt err - setSessionJson SessionError sessErr - - selectRep $ do - provideRep $ do - mr <- getMessageRender - let - encrypted :: ToJSON a => a -> Widget -> Widget - encrypted plaintextJson plaintext = do - if - | shouldEncrypt -> do - ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson - - [whamlet| -

_{MsgErrorResponseEncrypted} - 

-                        #{ciphertext}
-                    |]
-                | otherwise -> plaintext
-
-            errPage = case err of
-              NotFound -> [whamlet|
_{MsgErrorResponseNotFound}|]
-              InternalError err' -> encrypted err' [whamlet|
#{err'}|]
-              InvalidArgs errs -> [whamlet|
-                  
    
-                    $forall err' <- errs
-                      
  • #{err'}
-                 |]
-              NotAuthenticated -> [whamlet|
    _{MsgErrorResponseNotAuthenticated}|]
-              PermissionDenied err' -> [whamlet|
    #{err'}|]
-              BadMethod method -> [whamlet|
    _{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
-          siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
-            toWidget
-              [cassius|
-                .errMsg
-                  white-space: pre-wrap
-                  font-family: monospace
-              |]
-            errPage
-        provideRep . fmap PrettyValue $ case err of
-          PermissionDenied err' -> return $ object [ "message" JSON..= err' ]
-          InternalError err'
-            | shouldEncrypt -> do
-                ciphertext <- encodedSecretBox SecretBoxShort err'
-                return $ object [ "message" JSON..= ciphertext
-                                , "encrypted" JSON..= True
-                                ]
-            | otherwise -> return $ object [ "message" JSON..= err' ]
-          InvalidArgs errs -> return $ object [ "messages" JSON..= errs ]
-          _other -> return $ object []
-        provideRep $ case err of
-          PermissionDenied err' -> return err'
-          InternalError err'
-            | shouldEncrypt -> do
-                addHeader "Encrypted-Error-Message" "True"
-                encodedSecretBox SecretBoxPretty err'
-            | otherwise -> return err'
-          InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs
-          _other -> return Text.empty
-
-    defaultLayout = siteLayout' Nothing
-
-    -- The page to be redirected to when authentication is required.
-    authRoute _ = Just $ AuthR LoginR
-
-    isAuthorized = evalAccess
-
-    addStaticContent ext _mime content = do
-      UniWorX{appWidgetMemcached, appSettings'} <- getYesod
-      for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do
-        let expiry = maybe 0 ceiling memcachedExpiry
-            touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
-            add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
-            absoluteLink = unpack widgetMemcachedBaseUrl  fileName
-        C.catchIf Memcached.isKeyNotFound touch $ \_ ->
-          C.handleIf Memcached.isKeyExists (\_ -> return ()) add
-        return . Left $ pack absoluteLink
-      where
-        -- Generate a unique filename based on the content itself, this is used
-        -- for deduplication so a collision resistant hash function is required
-        --
-        -- SHA-3 (SHAKE256) seemed to be a future-proof choice
-        --
-        -- Length of hash is 144 bits instead of MD5's 128, so as to avoid
-        -- padding after base64-conversion
-        fileName = (<.> unpack ext)
-                 . unpack
-                 . decodeUtf8
-                 . Base64.encode
-                 . (convert :: Digest (SHAKE256 144) -> ByteString)
-                 . runConduitPure
-                 $ sourceList (Lazy.ByteString.toChunks content) .| sinkHash
-
-    fileUpload _site _length = FileUploadMemory lbsBackEnd
-
-    -- What messages should be logged. The following includes all messages when
-    -- in development, and warnings and errors in production.
-    shouldLogIO app _source level = do
-      LogSettings{..} <- readTVarIO $ appLogSettings app
-      return $ logAll || level >= logMinimumLevel
-
-    makeLogger = readTVarIO . snd . appLogger
-
-
--- langForm :: Form (Lang, Route UniWorX)
--- langForm csrf = do
---   lang <- selectLanguage appLanguages
---   route <- getCurrentRoute
---   (urlRes, urlView) <- mreq hiddenField ("" & addName ("referer" :: Text)) route
---   (langBoxRes, langBoxView) <- mreq
---     (selectField appLanguagesOpts)
---     ("" & addAttr "multiple" "multiple" & addAttr "size" (tshow . min 10 $ length appLanguages) & addAutosubmit & addName ("lang" :: Text))
---     (Just lang)
---   return ((,) <$> langBoxRes <*> urlRes, toWidget csrf <> fvInput urlView <> fvInput langBoxView)
-
-data MemcachedKeyFavourites
-  = MemcachedKeyFavouriteQuickActions CourseId AuthContext (NonEmpty Lang)
-  deriving (Eq, Read, Show, Generic, Typeable)
-  deriving anyclass (Hashable, Binary)
-
-data MemcachedLimitKeyFavourites
-  = MemcachedLimitKeyFavourites
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
-  deriving anyclass (Hashable, Binary)
-
-
-updateFavourites :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX)
-                 => Maybe (TermId, SchoolId, CourseShorthand) -- ^ Insert course into favourites, as appropriate
-                 -> ReaderT SqlBackend m ()
-updateFavourites cData = void . runMaybeT $ do
-  $logDebugS "updateFavourites" "Updating favourites"
-
-  now <- liftIO getCurrentTime
-  uid <- MaybeT $ liftHandler maybeAuthId
-  mcid  <- for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-  User{userMaxFavourites} <- MaybeT $ get uid
-
-  -- update Favourites
-  for_ mcid $ \cid ->
-    void . lift $ upsertBy
-      (UniqueCourseFavourite uid cid)
-      (CourseFavourite uid cid FavouriteVisited now)
-      [CourseFavouriteLastVisit =. now]
-  -- prune Favourites to user-defined size
-  oldFavs <- lift $ selectList [CourseFavouriteUser ==. uid] []
-  let deleteFavs = oldFavs
-        & sortOn ((courseFavouriteReason &&& Down . courseFavouriteLastVisit) . entityVal)
-        & drop userMaxFavourites
-        & filter ((<= FavouriteVisited) . courseFavouriteReason . entityVal)
-        & map entityKey
-  unless (null deleteFavs) $
-    lift $ deleteWhere [CourseFavouriteId <-. deleteFavs]
-
-
-siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX) => msg -> Widget -> Handler Html
-siteLayoutMsg msg widget = do
-  mr <- getMessageRender
-  siteLayout (toWgt $ mr msg) widget
-
-siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX) => msg -> Widget -> Handler Html
-siteLayoutMsg' = siteLayout . i18nHeading
-
-siteLayout :: Widget -- ^ `pageHeading`
-           -> Widget -> Handler Html
-siteLayout = siteLayout' . Just
-
-siteLayout' :: Maybe Widget -- ^ Optionally override `pageHeading`
-           -> Widget -> Handler Html
-siteLayout' headingOverride widget = do
-  AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings
-
-  isModal <- hasCustomHeader HeaderIsModal
-
-  primaryLanguage <- unsafeHead . Text.splitOn "-" <$> selectLanguage appLanguages
-
-  mcurrentRoute <- getCurrentRoute
-  let currentHandler = classifyHandler <$> mcurrentRoute
-
-  currentApproot' <- siteApproot <$> getYesod <*> (reqWaiRequest <$> getRequest)
-
-  -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
-  let
-    breadcrumbs' mcRoute = do
-      mr <- getMessageRender
-      case mcRoute of
-        Nothing -> return (mr MsgErrorResponseTitleNotFound, [])
-        Just cRoute -> do
-          (title, next) <- breadcrumb cRoute
-          crumbs <- go [] next
-          return (title, crumbs)
-      where
-        go crumbs  Nothing      = return crumbs
-        go crumbs (Just cRoute) = do
-          hasAccess <- hasReadAccessTo cRoute
-          (title, next) <- breadcrumb cRoute
-          go ((cRoute, title, hasAccess) : crumbs) next
-  (title, parents) <- breadcrumbs' mcurrentRoute
-
-  --         let isParent :: Route UniWorX -> Bool
-  --             isParent r = r == (fst parents)
-
-  isAuth <- isJust <$> maybeAuthId
-  
-  now <- liftIO getCurrentTime
-
-  -- Lookup Favourites & Theme if possible
-  (favourites', maxFavouriteTerms, currentTheme) <- do
-      muid <- maybeAuthPair
-
-      favCourses'' <- runDB . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do
-        E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse
-         E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid)
-
-        let isFavourite = E.not_ . E.isNothing $ courseFavourite E.?. CourseFavouriteId
-            isCurrent
-              | Just (CourseR tid ssh csh _) <- mcurrentRoute
-              =       course E.^. CourseTerm E.==. E.val tid
-                E.&&. course E.^. CourseSchool E.==. E.val ssh
-                E.&&. course E.^. CourseShorthand E.==. E.val csh
-              | otherwise
-              = E.false
-            notBlacklist = E.not_ . E.exists . E.from $ \courseNoFavourite ->
-              E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid)
-                   E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId
-            isParticipant = E.exists . E.from $ \participant ->
-              E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
-                   E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid)
-                   E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
-            isLecturer = E.exists . E.from $ \lecturer ->
-              E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
-                   E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid)
-            isCorrector = E.exists . E.from $ \(corrector `E.InnerJoin` sheet) -> do
-              E.on $ corrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
-               E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId
-              E.where_ $ E.just (corrector E.^. SheetCorrectorUser) E.==. E.val (view _1 <$> muid)
-            isTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do
-              E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
-               E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId
-              E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid)
-            isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor
-            courseVisible = courseIsVisible now course Nothing
-
-            reason = E.case_
-              [ E.when_ isCurrent    E.then_ . E.just $ E.val FavouriteCurrent
-              , E.when_ isAssociated E.then_ . E.just $ E.val FavouriteParticipant
-              ] (E.else_ $ courseFavourite E.?. CourseFavouriteReason)
-
-        E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent
-
-        return (course, reason, courseVisible)
-
-      favCourses' <- forM favCourses'' $ \(course@(Entity _ Course{..}), reason, E.Value courseVisible) -> do
-        mayView <- hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CShowR
-        mayEdit <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
-        return (course, reason, courseVisible, mayView, mayEdit)
-
-      let favCourses = favCourses' & filter (\(_, _, _, mayView, _) -> mayView)
-
-      return ( favCourses
-             , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid
-             , maybe userDefaultTheme userTheme $ view _2 <$> muid
-             )
-
-  let favouriteTerms :: [TermIdentifier]
-      favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _, _, _, _) -> Set.singleton $ unTermKey courseTerm) favourites'
-  
-  favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite, courseVisible, mayView, mayEdit)
-      -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
-             favouriteReason = fromMaybe FavouriteCurrent mFavourite
-         in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do
-              ctx <- getAuthContext
-              MsgRenderer mr <- getMsgRenderer
-              langs <- selectLanguages appLanguages <$> languages
-              let cK = MemcachedKeyFavouriteQuickActions cId ctx langs
-              $logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..."
-              items <- memcachedLimitedKeyTimeoutBy
-                MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1
-                (Right <$> appFavouritesQuickActionsCacheTTL)
-                appFavouritesQuickActionsTimeout
-                cK
-                cK
-                . observeFavouritesQuickActionsDuration $ do
-                  $logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..."
-                  items' <- pageQuickActions NavQuickViewFavourite courseRoute
-                  items <- forM items' $ \n@NavLink{navLabel} -> (mr navLabel,) <$> toTextUrl n
-                  $logDebugS "FavouriteQuickActions" $ tshow cK <> " Done."
-                  return items
-              $logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items)
-              return (c, courseRoute, items, favouriteReason, courseVisible, mayView, mayEdit)
-
-  nav'' <- mconcat <$> sequence
-    [ defaultLinks
-    , maybe (return []) pageActions mcurrentRoute
-    ]
-  nav' <- catMaybes <$> mapM (runMaybeT . navAccess) nav''
-  nav <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse toTextUrl (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> toTextUrl nc) (n ^. _navChildren)
-
-  mmsgs <- if
-    | isModal -> return mempty
-    | otherwise -> do
-        applySystemMessages
-        authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags
-        forM_ authTagPivots $
-          \authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute]))
-        getMessages
-
-  -- (langFormView, langFormEnctype) <- generateFormPost $ identifyForm FIDLanguage langForm
-  -- let langFormView' = wrapForm langFormView def
-  --       { formAction = Just $ SomeRoute LangR
-  --       , formSubmit = FormAutoSubmit
-  --       , formEncoding = langFormEnctype
-  --       }
-
-  let highlight :: HasRoute UniWorX url => url -> Bool
-      -- ^ highlight last route in breadcrumbs, favorites taking priority
-      highlight = (highR ==) . Just . urlRoute
-        where crumbs = mcons mcurrentRoute $ view _1 <$> reverse parents
-              navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to urlRoute) nav
-              highR  = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs
-      highlightNav = (||) <$> navForceActive <*> highlight
-      favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool, Bool, Bool)]
-      favouriteTermReason tid favReason' = favourites
-        & filter (\(Course{..}, _, _, favReason, _, _, _) -> unTermKey courseTerm == tid && favReason == favReason')
-        & sortOn (\(Course{..}, _, _, _, _, _, _) -> courseName)
-
-      -- We break up the default layout into two components:
-      -- default-layout is the contents of the body tag, and
-      -- default-layout-wrapper is the entire page. Since the final
-      -- value passed to hamletToRepHtml cannot be a widget, this allows
-      -- you to use normal widget features in default-layout.
-
-      navWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)]) -> Widget
-      navWidget (n, navIdent, navRoute', navChildren') = case n of
-        NavHeader{ navLink = navLink@NavLink{..}, .. }
-          | NavTypeLink{..} <- navType
-          , navModal
-            -> customModal Modal
-                 { modalTriggerId = Just navIdent
-                 , modalId = Nothing
-                 , modalTrigger = \(Just route) ident -> $(widgetFile "widgets/navbar/item")
-                 , modalContent = Left $ SomeRoute navLink
-                 }
-          | NavTypeLink{} <- navType
-            -> let route = navRoute'
-                   ident = navIdent
-                in $(widgetFile "widgets/navbar/item")
-        NavPageActionPrimary{ navLink = navLink@NavLink{..} }
-          -> let pWidget
-                   | NavTypeLink{..} <- navType
-                   , navModal
-                     = customModal Modal
-                         { modalTriggerId = Just navIdent
-                         , modalId = Nothing
-                         , modalTrigger = \(Just route) ident -> $(widgetFile "widgets/pageaction/primary")
-                         , modalContent = Left $ SomeRoute navLink
-                         }
-                   | NavTypeLink{} <- navType
-                     = let route = navRoute'
-                           ident = navIdent
-                        in $(widgetFile "widgets/pageaction/primary")
-                   | otherwise
-                     = error "not implemented"
-                 sWidgets = navChildren'
-                   & map (\(l, i, r) -> navWidget (NavPageActionSecondary l, i, Just r, []))
-              in $(widgetFile "widgets/pageaction/primary-wrapper")
-        NavPageActionSecondary{ navLink = navLink@NavLink{..} }
-          | NavTypeLink{..} <- navType
-          , navModal
-            -> customModal Modal
-                 { modalTriggerId = Just navIdent
-                 , modalId = Nothing
-                 , modalTrigger = \(Just route) ident -> $(widgetFile "widgets/pageaction/secondary")
-                 , modalContent = Left $ SomeRoute navLink
-                 }
-          | NavTypeLink{} <- navType
-            -> let route = navRoute'
-                   ident = navIdent
-                in $(widgetFile "widgets/pageaction/secondary")
-        NavHeaderContainer{..} -> $(widgetFile "widgets/navbar/container")
-        NavFooter{ navLink = navLink@NavLink{..} }
-          | NavTypeLink{..} <- navType
-          , not navModal
-            -> let route = navRoute'
-                   ident = navIdent
-                in $(widgetFile "widgets/footer/link")
-        _other -> error "not implemented"
-
-      navContainerItemWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)])
-                             -> (NavLink, Text, Text)
-                             -> Widget
-      navContainerItemWidget (n, _navIdent, _navRoute', _navChildren') (iN@NavLink{..}, iNavIdent, iNavRoute) = case n of
-        NavHeaderContainer{}
-          | NavTypeLink{..} <- navType
-          , navModal
-            -> customModal Modal
-                 { modalTriggerId = Just iNavIdent
-                 , modalId = Nothing
-                 , modalTrigger = \(Just route) ident -> $(widgetFile "widgets/navbar/navbar-container-item--link")
-                 , modalContent = Left $ SomeRoute iN
-                 }
-          | NavTypeLink{} <- navType
-            -> let route = iNavRoute
-                   ident = iNavIdent
-                in $(widgetFile "widgets/navbar/navbar-container-item--link")
-          | NavTypeButton{..} <- navType -> do
-              csrfToken <- reqToken <$> getRequest
-              wrapForm $(widgetFile "widgets/navbar/navbar-container-item--button") def
-                { formMethod = navMethod
-                , formSubmit = FormNoSubmit
-                , formAction = Just $ SomeRoute iN
-                }
-        _other -> error "not implemented"
-
-      navbar :: Widget
-      navbar = do
-        $(widgetFile "widgets/navbar/navbar")
-        forM_ (filter isNavHeaderContainer nav) $ \(_, containerIdent, _, _) ->
-          toWidget $(cassiusFile "templates/widgets/navbar/container-radio.cassius")
-        where isNavHeaderPrimary   = has $ _1 . _navHeaderRole . only NavHeaderPrimary
-              isNavHeaderSecondary = has $ _1 . _navHeaderRole . only NavHeaderSecondary
-      asidenav :: Widget
-      asidenav = $(widgetFile "widgets/asidenav/asidenav")
-        where
-          logo = preEscapedToMarkup $ decodeUtf8 $(embedFile "assets/lmu/logo.svg")
-      footer :: Widget
-      footer = $(widgetFile "widgets/footer/footer")
-        where isNavFooter = has $ _1 . _NavFooter
-      alerts :: Widget
-      alerts = $(widgetFile "widgets/alerts/alerts")
-      contentHeadline :: Maybe Widget
-      contentHeadline = headingOverride <|> (pageHeading =<< mcurrentRoute)
-      breadcrumbsWgt :: Widget
-      breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs/breadcrumbs")
-      pageaction :: Widget
-      pageaction = $(widgetFile "widgets/pageaction/pageaction")
-      -- functions to determine if there are page-actions (primary or secondary)
-      hasPageActions, hasSecondaryPageActions, hasPrimaryPageActions :: Bool
-      hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions
-      hasSecondaryPageActions = has (folded . _1 . _NavPageActionSecondary) nav
-      hasPrimaryPageActions   = has (folded . _1 . _NavPageActionPrimary  ) nav
-      hasPrimarySubActions = has (folded . _1 . filtered (is _NavPageActionPrimary) . _navChildren . folded) nav
-      contentRibbon :: Maybe Widget
-      contentRibbon = fmap toWidget appRibbon
-
-      isNavHeaderContainer = has $ _1 . _NavHeaderContainer
-      isPageActionPrimary = has $ _1 . _NavPageActionPrimary
-      isPageActionSecondary = has $ _1 . _NavPageActionSecondary
-
-  MsgRenderer mr <- getMsgRenderer
-  let
-    -- See Utils.Frontend.I18n and files in messages/frontend for message definitions
-    frontendI18n = toJSON (mr :: FrontendMessage -> Text)
-  frontendDatetimeLocale <- toJSON <$> selectLanguage frontendDatetimeLocales
-
-  pc <- widgetToPageContent $ do
-      webpackLinks_main StaticR
-      toWidget $(juliusFile "templates/i18n.julius")
-      whenIsJust currentApproot' $ \currentApproot ->
-        toWidget $(juliusFile "templates/approot.julius")
-      whenIsJust mcurrentRoute $ \currentRoute' -> do
-        currentRoute <- toTextUrl currentRoute'
-        toWidget $(juliusFile "templates/current-route.julius")
-      wellKnownHtmlLinks
-
-      $(widgetFile "default-layout")
-  withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
-
-
-getSystemMessageState :: (MonadHandler m, HandlerSite m ~ UniWorX) => SystemMessageId -> m UserSystemMessageState
-getSystemMessageState smId = liftHandler $ do
-  muid <- maybeAuthId
-  reqSt <- $cachedHere getSystemMessageStateRequest
-  dbSt <- $cachedHere $ maybe (return mempty) getDBSystemMessageState muid
-  let MergeHashMap smSt = reqSt <> dbSt
-      smSt' = MergeHashMap $ HashMap.filter (/= mempty) smSt
-  when (smSt' /= reqSt) $
-        setRegisteredCookieJson CookieSystemMessageState
-    =<< ifoldMapM (\smId' v -> MergeHashMap <$> (HashMap.singleton <$> encrypt smId' <*> pure v :: Handler (HashMap CryptoUUIDSystemMessage _))) smSt'
-
-  return . fromMaybe mempty $ HashMap.lookup smId smSt
-  where
-    getSystemMessageStateRequest =
-          (lookupRegisteredCookiesJson id CookieSystemMessageState :: Handler (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState))
-      >>= ifoldMapM (\(cID :: CryptoUUIDSystemMessage) v -> MergeHashMap <$> (maybeT (return mempty) . catchMPlus (Proxy @CryptoIDError) $ HashMap.singleton <$> decrypt cID <*> pure v))
-    getDBSystemMessageState uid = runDB . runConduit $ selectSource [ SystemMessageHiddenUser ==. uid ] [] .| C.foldMap foldSt
-      where foldSt (Entity _ SystemMessageHidden{..})
-              = MergeHashMap . HashMap.singleton systemMessageHiddenMessage $ mempty { userSystemMessageHidden = Just systemMessageHiddenTime }
-
-applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m ()
-applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do
-  lift $ maybeAuthId >>= traverse_ syncSystemMessageHidden
-
-  cRoute <- lift getCurrentRoute
-  guard $ cRoute /= Just NewsR
-
-  lift . runDB . runConduit $ selectSource [] [Asc SystemMessageManualPriority] .| C.mapM_ applyMessage
-  where
-    syncSystemMessageHidden uid = runDB $ do
-      smSt <- lookupRegisteredCookiesJson id CookieSystemMessageState :: DB (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState)
-      iforM_ smSt $ \cID UserSystemMessageState{..} -> do
-        smId <- decrypt cID
-        whenIsJust userSystemMessageHidden $ \systemMessageHiddenTime -> void $
-          upsert SystemMessageHidden
-            { systemMessageHiddenMessage = smId
-            , systemMessageHiddenUser = uid
-            , systemMessageHiddenTime
-            }
-            [ SystemMessageHiddenTime =. systemMessageHiddenTime ]
-
-        when (maybe False (maybe (const True) (<=) userSystemMessageHidden) userSystemMessageUnhidden) $ do
-          deleteBy $ UniqueSystemMessageHidden uid smId
-
-        modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm)
-          -> fmap MergeHashMap . assertM' (/= mempty) $
-               HashMap.update (\smSt' -> assertM' (/= mempty) $ smSt' { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = Nothing }) cID hm
-
-    applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do
-      guard $ not systemMessageNewsOnly
-
-      cID <- encrypt smId
-      void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False
-
-      now <- liftIO getCurrentTime
-      guard $ NTop systemMessageFrom <= NTop (Just now)
-      guard $ NTop (Just now) < NTop systemMessageTo
-
-      UserSystemMessageState{..} <- lift $ getSystemMessageState smId
-      guard $ userSystemMessageShown <= Just systemMessageLastChanged
-      guard $ userSystemMessageHidden <= Just systemMessageLastUnhide
-
-      (_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId
-      let
-        (summary, content) = case smTrans of
-          Nothing -> (systemMessageSummary, systemMessageContent)
-          Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
-      case summary of
-        Just s ->
-          addMessageWidget systemMessageSeverity $ msgModal (toWidget s) (Left . SomeRoute $ MessageR cID)
-        Nothing -> addMessage systemMessageSeverity content
-
-      tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $
-        HashMap.singleton cID mempty{ userSystemMessageShown = Just now }
-
--- Define breadcrumbs.
-i18nCrumb :: ( RenderMessage (HandlerSite m) msg, MonadHandler m )
-          => msg
-          -> Maybe (Route (HandlerSite m))
-          -> m (Text, Maybe (Route (HandlerSite m)))
-i18nCrumb msg mbR = do
-  mr <- getMessageRender
-  return (mr msg, mbR)
-
--- `breadcrumb` _really_ needs to be total for _all_ routes
---
--- Even if routes are POST only or don't usually use `siteLayout` they will if
--- an error occurs.
---
--- Keep in mind that Breadcrumbs are also shown by the 403-Handler,
--- 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 NewsR
-  breadcrumb (StaticR _)      = i18nCrumb MsgBreadcrumbStatic    Nothing
-  breadcrumb (WellKnownR _)   = i18nCrumb MsgBreadcrumbWellKnown Nothing
-  breadcrumb MetricsR         = i18nCrumb MsgBreadcrumbMetrics   Nothing
-
-  breadcrumb NewsR            = i18nCrumb MsgMenuNews      Nothing
-  breadcrumb UsersR           = i18nCrumb MsgMenuUsers   $ Just AdminR
-  breadcrumb AdminUserAddR    = i18nCrumb MsgMenuUserAdd $ Just UsersR
-  breadcrumb (AdminUserR cID) = maybeT (i18nCrumb MsgBreadcrumbUser $ Just UsersR) $ do
-    guardM . hasReadAccessTo $ AdminUserR cID
-    uid <- decrypt cID
-    User{..} <- MaybeT . runDB $ get uid
-    return (userDisplayName, Just UsersR)
-  breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID
-  breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID
-  breadcrumb (UserNotificationR cID) = do
-    mayList <- hasReadAccessTo UsersR
-    if
-      | mayList
-        -> i18nCrumb MsgMenuUserNotifications . Just $ AdminUserR cID
-      | otherwise
-        -> i18nCrumb MsgMenuUserNotifications $ Just ProfileR
-  breadcrumb (UserPasswordR cID) = do
-    mayList <- hasReadAccessTo UsersR
-    if
-      | mayList
-        -> i18nCrumb MsgMenuUserPassword . Just $ AdminUserR cID
-      | otherwise
-        -> i18nCrumb MsgMenuUserPassword $ Just ProfileR
-  breadcrumb AdminNewFunctionaryInviteR = i18nCrumb MsgMenuLecturerInvite $ Just UsersR
-  breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing
-
-  breadcrumb AdminR           = i18nCrumb MsgAdminHeading           Nothing
-  breadcrumb AdminFeaturesR   = i18nCrumb MsgAdminFeaturesHeading $ Just AdminR
-  breadcrumb AdminTestR       = i18nCrumb MsgMenuAdminTest        $ Just AdminR
-  breadcrumb AdminErrMsgR     = i18nCrumb MsgMenuAdminErrMsg      $ Just AdminR
-  breadcrumb AdminTokensR     = i18nCrumb MsgMenuAdminTokens      $ Just AdminR
-  breadcrumb AdminCrontabR    = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
-
-  breadcrumb SchoolListR      = i18nCrumb MsgMenuSchoolList       $ Just AdminR
-  breadcrumb (SchoolR ssh SchoolEditR) = maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
-    School{..} <- MaybeT . runDB $ get ssh
-    return (CI.original schoolName, Just SchoolListR)
-  breadcrumb SchoolNewR       = i18nCrumb MsgMenuSchoolNew        $ Just SchoolListR
-
-  breadcrumb (ExamOfficeR EOExamsR)  = i18nCrumb MsgMenuExamOfficeExams    Nothing
-  breadcrumb (ExamOfficeR EOFieldsR) = i18nCrumb MsgMenuExamOfficeFields . Just $ ExamOfficeR EOExamsR
-  breadcrumb (ExamOfficeR EOUsersR)  = i18nCrumb MsgMenuExamOfficeUsers . Just $ ExamOfficeR EOExamsR
-  breadcrumb (ExamOfficeR EOUsersInviteR) = i18nCrumb MsgBreadcrumbExamOfficeUserInvite Nothing
-
-  breadcrumb InfoR            = i18nCrumb MsgMenuInformation     Nothing
-  breadcrumb InfoLecturerR    = i18nCrumb MsgInfoLecturerTitle $ Just InfoR
-  breadcrumb LegalR           = i18nCrumb MsgMenuLegal         $ Just InfoR
-  breadcrumb InfoAllocationR  = i18nCrumb MsgBreadcrumbAllocationInfo $ Just InfoR
-  breadcrumb VersionR         = i18nCrumb MsgMenuVersion       $ Just InfoR
-  breadcrumb FaqR             = i18nCrumb MsgBreadcrumbFaq     $ Just InfoR
-
-
-  breadcrumb HelpR            = i18nCrumb MsgMenuHelp            Nothing
-
-
-  breadcrumb HealthR          = i18nCrumb MsgMenuHealth          Nothing
-  breadcrumb InstanceR        = i18nCrumb MsgMenuInstance        Nothing
-
-  breadcrumb ProfileR         = i18nCrumb MsgBreadcrumbProfile   Nothing
-  breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail  $ Just ProfileR
-  breadcrumb ProfileDataR     = i18nCrumb MsgMenuProfileData   $ Just ProfileR
-  breadcrumb AuthPredsR       = i18nCrumb MsgMenuAuthPreds     $ Just ProfileR
-  breadcrumb CsvOptionsR      = i18nCrumb MsgCsvOptions        $ Just ProfileR
-  breadcrumb LangR            = i18nCrumb MsgMenuLanguage      $ Just ProfileR
-
-  breadcrumb StorageKeyR      = i18nCrumb MsgBreadcrumbStorageKey Nothing
-
-  breadcrumb TermShowR              = i18nCrumb MsgMenuTermShow    $ Just NewsR
-  breadcrumb TermCurrentR           = i18nCrumb MsgMenuTermCurrent $ Just TermShowR
-  breadcrumb TermEditR              = i18nCrumb MsgMenuTermCreate  $ Just TermShowR
-  breadcrumb (TermEditExistR tid)   = i18nCrumb MsgMenuTermEdit    . Just $ TermCourseListR tid
-  breadcrumb (TermCourseListR tid)  = maybeT (i18nCrumb MsgBreadcrumbTerm $ Just CourseListR) $ do -- redirect only, used in other breadcrumbs
-    guardM . lift . runDB $ isJust <$> get tid
-    i18nCrumb (ShortTermIdentifier $ unTermKey tid) $ Just CourseListR
-
-  breadcrumb (TermSchoolCourseListR tid ssh) = maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ TermCourseListR tid) $ do -- redirect only, used in other breadcrumbs
-    guardM . lift . runDB $
-      (&&) <$> fmap isJust (get ssh)
-           <*> fmap isJust (get tid)
-    return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid)
-
-  breadcrumb AllocationListR        = i18nCrumb MsgAllocationListTitle $ Just NewsR
-  breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of
-    AShowR      -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do
-      mr <- getMessageRender
-      Entity _ Allocation{allocationName} <- MaybeT . runDB . getBy $ TermSchoolAllocationShort tid ssh ash
-      return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just AllocationListR)
-    ARegisterR  -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR
-    AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do
-      cid <- decrypt cID
-      Course{..} <- hoist runDB $ do
-        aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash
-        guardM . lift $ exists [ AllocationCourseAllocation ==. aid, AllocationCourseCourse ==. cid ]
-        MaybeT $ get cid
-      return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR)
-    AUsersR     -> i18nCrumb MsgBreadcrumbAllocationUsers . Just $ AllocationR tid ssh ash AShowR
-    APriosR     -> i18nCrumb MsgBreadcrumbAllocationPriorities . Just $ AllocationR tid ssh ash AUsersR
-    AComputeR   -> i18nCrumb MsgBreadcrumbAllocationCompute . Just $ AllocationR tid ssh ash AUsersR
-    AAcceptR    -> i18nCrumb MsgBreadcrumbAllocationAccept . Just $ AllocationR tid ssh ash AUsersR
-
-  breadcrumb ParticipantsListR      = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR
-  breadcrumb (ParticipantsR _ _)    = i18nCrumb MsgBreadcrumbParticipants     $ Just ParticipantsListR
-  breadcrumb ParticipantsIntersectR = i18nCrumb MsgMenuParticipantsIntersect  $ Just ParticipantsListR
-
-  breadcrumb  CourseListR                 = i18nCrumb MsgMenuCourseList   Nothing
-  breadcrumb  CourseNewR                  = i18nCrumb MsgMenuCourseNew  $ Just CourseListR
-  breadcrumb (CourseR tid ssh csh CShowR) = maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ TermSchoolCourseListR tid ssh) $ do
-    guardM . lift . runDB . existsBy $ TermSchoolCourseShort tid ssh csh
-    return (CI.original csh, Just $ TermSchoolCourseListR tid ssh)
-  breadcrumb (CourseR tid ssh csh CEditR)     = i18nCrumb MsgMenuCourseEdit . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh CUsersR)    = i18nCrumb MsgMenuCourseMembers . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh CAddUserR)  = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR
-  breadcrumb (CourseR tid ssh csh CInviteR)   = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh (CUserR cID)) = maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do
-    guardM . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID
-    uid <- decrypt cID
-    User{userDisplayName} <- MaybeT . runDB $ get uid
-    return (userDisplayName, Just $ CourseR tid ssh csh CUsersR)
-  breadcrumb (CourseR tid ssh csh CCorrectionsR) = i18nCrumb MsgMenuSubmissions . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh CAssignR)   = i18nCrumb MsgMenuCorrectionsAssign . Just $ CourseR tid ssh csh CCorrectionsR
-  breadcrumb (CourseR tid ssh csh SheetListR) = i18nCrumb MsgMenuSheetList . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh SheetNewR ) = i18nCrumb MsgMenuSheetNew . Just $ CourseR tid ssh csh SheetListR
-  breadcrumb (CourseR tid ssh csh SheetCurrentR) = i18nCrumb MsgMenuSheetCurrent . Just $ CourseR tid ssh csh SheetListR
-  breadcrumb (CourseR tid ssh csh SheetOldUnassignedR) = i18nCrumb MsgMenuSheetOldUnassigned . Just $ CourseR tid ssh csh SheetListR
-  breadcrumb (CourseR tid ssh csh CCommR    ) = i18nCrumb MsgMenuCourseCommunication . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh CTutorialListR) = i18nCrumb MsgMenuTutorialList . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh CTutorialNewR) = i18nCrumb MsgMenuTutorialNew . Just $ CourseR tid ssh csh CTutorialListR
-  breadcrumb (CourseR tid ssh csh CFavouriteR) = i18nCrumb MsgBreadcrumbCourseFavourite . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh CRegisterR)  = i18nCrumb MsgBreadcrumbCourseRegister . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh CRegisterTemplateR) = i18nCrumb MsgBreadcrumbCourseRegisterTemplate . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh CLecInviteR) = i18nCrumb MsgBreadcrumbLecturerInvite . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh CDeleteR) = i18nCrumb MsgMenuCourseDelete . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh CHiWisR) = i18nCrumb MsgBreadcrumbHiWis . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh CNotesR) = i18nCrumb MsgBreadcrumbCourseNotes . Just $ CourseR tid ssh csh CShowR
-
-  breadcrumb (CourseR tid ssh csh CNewsNewR)    = i18nCrumb MsgMenuCourseNewsNew . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh (CourseNewsR cID sRoute)) = case sRoute of
-    CNShowR   -> i18nCrumb MsgBreadcrumbCourseNews . Just $ CourseR tid ssh csh CShowR
-    CNEditR   -> i18nCrumb MsgMenuCourseNewsEdit . Just $ CNewsR tid ssh csh cID CNShowR
-    CNDeleteR -> i18nCrumb MsgBreadcrumbCourseNewsDelete . Just $ CNewsR tid ssh csh cID CNShowR
-    CNArchiveR -> i18nCrumb MsgBreadcrumbCourseNewsArchive . Just $ CNewsR tid ssh csh cID CNShowR
-    CNFileR _ -> i18nCrumb MsgBreadcrumbCourseNewsFile . Just $ CNewsR tid ssh csh cID CNShowR
-
-  breadcrumb (CourseR tid ssh csh CEventsNewR)    = i18nCrumb MsgMenuCourseEventNew . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh (CourseEventR _cID sRoute)) = case sRoute of
-    CEvEditR   -> i18nCrumb MsgMenuCourseEventEdit . Just $ CourseR tid ssh csh CShowR
-    CEvDeleteR -> i18nCrumb MsgBreadcrumbCourseEventDelete . Just $ CourseR tid ssh csh CShowR
-
-  breadcrumb (CourseR tid ssh csh CExamListR) = i18nCrumb MsgMenuExamList . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh CExamNewR) = i18nCrumb MsgMenuExamNew . Just $ CourseR tid ssh csh CExamListR
-
-  breadcrumb (CourseR tid ssh csh CApplicationsR) = i18nCrumb MsgMenuCourseApplications . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh CAppsFilesR) = i18nCrumb MsgBreadcrumbCourseAppsFiles . Just $ CourseR tid ssh csh CApplicationsR
-
-  breadcrumb (CourseR tid ssh csh (CourseApplicationR cID sRoute)) = case sRoute of
-    CAEditR -> maybeT (i18nCrumb MsgBreadcrumbApplicant . Just $ CourseR tid ssh csh CApplicationsR) $ do
-      guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR
-      appId <- decrypt cID
-      User{..} <- hoist runDB $ MaybeT (get appId) >>= MaybeT . get . courseApplicationUser
-      return (userDisplayName, Just $ CourseR tid ssh csh CApplicationsR)
-    CAFilesR -> i18nCrumb MsgBreadcrumbApplicationFiles . Just $ CApplicationR tid ssh csh cID CAEditR
-
-  breadcrumb (CourseR tid ssh csh (ExamR examn sRoute)) = case sRoute of
-    EShowR    -> maybeT (i18nCrumb MsgBreadcrumbExam . Just $ CourseR tid ssh csh CExamListR) $ do
-      guardM . hasReadAccessTo $ CExamR tid ssh csh examn EShowR
-      return (CI.original examn, Just $ CourseR tid ssh csh CExamListR)
-    EEditR    -> i18nCrumb MsgMenuExamEdit . Just $ CExamR tid ssh csh examn EShowR
-    EUsersR   -> i18nCrumb MsgMenuExamUsers . Just $ CExamR tid ssh csh examn EShowR
-    EAddUserR -> i18nCrumb MsgMenuExamAddMembers . Just $ CExamR tid ssh csh examn EUsersR
-    EGradesR  -> i18nCrumb MsgMenuExamGrades . Just $ CExamR tid ssh csh examn EShowR
-    ECInviteR  -> i18nCrumb MsgBreadcrumbExamCorrectorInvite . Just $ CExamR tid ssh csh examn EShowR
-    EInviteR   -> i18nCrumb MsgBreadcrumbExamParticipantInvite . Just $ CExamR tid ssh csh examn EShowR
-    ERegisterR -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR
-    ERegisterOccR _occn -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR
-    EAutoOccurrenceR -> i18nCrumb MsgBreadcrumbExamAutoOccurrence . Just $ CExamR tid ssh csh examn EUsersR
-    ECorrectR  -> i18nCrumb MsgMenuExamCorrect . Just $ CExamR tid ssh csh examn EShowR
-
-  breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of
-    TUsersR  -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do
-      guardM . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR
-      return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR)
-    TEditR   -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR
-    TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR
-    TCommR   -> i18nCrumb MsgMenuTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR
-    TRegisterR -> i18nCrumb MsgBreadcrumbTutorialRegister . Just $ CourseR tid ssh csh CShowR
-    TInviteR -> i18nCrumb MsgBreadcrumbTutorInvite . Just $ CTutorialR tid ssh csh tutn TUsersR
-
-  breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of
-    SShowR -> maybeT (i18nCrumb MsgBreadcrumbSheet . Just $ CourseR tid ssh csh SheetListR) $ do
-      guardM . hasReadAccessTo $ CSheetR tid ssh csh shn SShowR
-      return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
-    SEditR -> i18nCrumb MsgMenuSheetEdit . Just $ CSheetR tid ssh csh shn SShowR
-    SDelR  -> i18nCrumb MsgMenuSheetDelete . Just $ CSheetR tid ssh csh shn SShowR
-    SSubsR -> i18nCrumb MsgMenuSubmissions . Just $ CSheetR tid ssh csh shn SShowR
-    SAssignR -> i18nCrumb MsgMenuCorrectionsAssign . Just $ CSheetR tid ssh csh shn SSubsR
-    SubmissionNewR -> i18nCrumb MsgMenuSubmissionNew . Just $ CSheetR tid ssh csh shn SShowR
-    SubmissionOwnR -> i18nCrumb MsgMenuSubmissionOwn . Just $ CSheetR tid ssh csh shn SShowR
-    SubmissionR cid sRoute' -> case sRoute' of
-      SubShowR -> do
-        mayList <- hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR
-        if
-          | mayList
-            -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SSubsR
-          | otherwise
-            -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SShowR
-      CorrectionR -> i18nCrumb MsgMenuCorrection . Just $ CSubmissionR tid ssh csh shn cid SubShowR
-      SubDelR -> i18nCrumb MsgMenuSubmissionDelete . Just $ CSubmissionR tid ssh csh shn cid SubShowR
-      SubAssignR -> i18nCrumb MsgCorrectorAssignTitle . Just $ CSubmissionR tid ssh csh shn cid SubShowR
-      SInviteR -> i18nCrumb MsgBreadcrumbSubmissionUserInvite . Just $ CSubmissionR tid ssh csh shn cid SubShowR
-      SubArchiveR sft -> i18nCrumb sft . Just $ CSubmissionR tid ssh csh shn cid SubShowR
-      SubDownloadR _ _ -> i18nCrumb MsgBreadcrumbSubmissionFile . Just $ CSubmissionR tid ssh csh shn cid SubShowR
-    SArchiveR -> i18nCrumb MsgBreadcrumbSheetArchive . Just $ CSheetR tid ssh csh shn SShowR
-    SIsCorrR -> i18nCrumb MsgBreadcrumbSheetIsCorrector . Just $ CSheetR tid ssh csh shn SShowR
-    SPseudonymR -> i18nCrumb MsgBreadcrumbSheetPseudonym . Just $ CSheetR tid ssh csh shn SShowR
-    SCorrInviteR -> i18nCrumb MsgBreadcrumbSheetCorrectorInvite . Just $ CSheetR tid ssh csh shn SShowR
-    SZipR sft -> i18nCrumb sft . Just $ CSheetR tid ssh csh shn SShowR
-    SFileR _ _ -> i18nCrumb MsgBreadcrumbSheetFile . Just $ CSheetR tid ssh csh shn SShowR
-    SPersonalFilesR -> i18nCrumb MsgBreadcrumbSheetPersonalisedFiles . Just $ CSheetR tid ssh csh shn SShowR
-
-  breadcrumb (CourseR tid ssh csh MaterialListR) = i18nCrumb MsgMenuMaterialList . Just $ CourseR tid ssh csh CShowR
-  breadcrumb (CourseR tid ssh csh MaterialNewR ) = i18nCrumb MsgMenuMaterialNew . Just $ CourseR tid ssh csh MaterialListR
-  breadcrumb (CourseR tid ssh csh (MaterialR mnm sRoute)) = case sRoute of
-    MShowR -> maybeT (i18nCrumb MsgBreadcrumbMaterial . Just $ CourseR tid ssh csh MaterialListR) $ do
-      guardM . hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR
-      return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR)
-    MEditR -> i18nCrumb MsgMenuMaterialEdit . Just $ CMaterialR tid ssh csh mnm MShowR
-    MDelR  -> i18nCrumb MsgMenuMaterialDelete . Just $ CMaterialR tid ssh csh mnm MShowR
-    MArchiveR -> i18nCrumb MsgBreadcrumbMaterialArchive . Just $ CMaterialR tid ssh csh mnm MShowR
-    MFileR _ -> i18nCrumb MsgBreadcrumbMaterialFile . Just $ CMaterialR tid ssh csh mnm MShowR
-
-  breadcrumb (CourseR tid ssh csh CPersonalFilesR) = i18nCrumb MsgBreadcrumbCourseSheetPersonalisedFiles . Just $ CourseR tid ssh csh CShowR
-
-  breadcrumb CorrectionsR         = i18nCrumb MsgMenuCorrections Nothing
-  breadcrumb CorrectionsUploadR   = i18nCrumb MsgMenuCorrectionsUpload $ Just CorrectionsR
-  breadcrumb CorrectionsCreateR   = i18nCrumb MsgMenuCorrectionsCreate $ Just CorrectionsR
-  breadcrumb CorrectionsGradeR    = i18nCrumb MsgMenuCorrectionsGrade $ Just CorrectionsR
-  breadcrumb CorrectionsDownloadR = i18nCrumb MsgMenuCorrectionsDownload $ Just CorrectionsR
-
-  breadcrumb (CryptoUUIDDispatchR _) = i18nCrumb MsgBreadcrumbCryptoIDDispatch Nothing
-
-  breadcrumb (MessageR _) = do
-    mayList <- (== Authorized) <$> evalAccess MessageListR False
-    if
-      | mayList   -> i18nCrumb MsgBreadcrumbSystemMessage $ Just MessageListR
-      | otherwise -> i18nCrumb MsgBreadcrumbSystemMessage $ Just NewsR
-  breadcrumb MessageListR = i18nCrumb MsgMenuMessageList $ Just AdminR
-  breadcrumb (MessageHideR cID) = i18nCrumb MsgBreadcrumbMessageHide . Just $ MessageR cID
-
-  breadcrumb GlossaryR = i18nCrumb MsgMenuGlossary $ Just InfoR
-
-  breadcrumb EExamListR = i18nCrumb MsgMenuExternalExamList Nothing
-  breadcrumb EExamNewR = do
-    isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR
-    i18nCrumb MsgBreadcrumbExternalExamNew . Just $ if
-      | isEO -> ExamOfficeR EOExamsR
-      | otherwise -> EExamListR
-  breadcrumb (EExamR tid ssh coursen examn sRoute) = case sRoute of
-    EEShowR -> do
-      isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR
-      maybeT (i18nCrumb MsgBreadcrumbExternalExam . Just $ bool EExamListR (ExamOfficeR EOExamsR) isEO) $ do
-        guardM . hasReadAccessTo $ EExamR tid ssh coursen examn EEShowR
-        i18nCrumb (MsgBreadcrumbExternalExamShow coursen examn) . Just $ if
-          | isEO -> ExamOfficeR EOExamsR
-          | otherwise -> EExamListR
-    EEEditR -> i18nCrumb MsgBreadcrumbExternalExamEdit . Just $ EExamR tid ssh coursen examn EEShowR
-    EEUsersR -> i18nCrumb MsgBreadcrumbExternalExamUsers . Just $ EExamR tid ssh coursen examn EEShowR
-    EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR
-    EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR
-
-  -- breadcrumb  _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all
-
-submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId]
-submissionList tid csh shn uid = E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
-  E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
-  E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
-  E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
-
-  E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
-       E.&&. sheet E.^. SheetName E.==. E.val shn
-       E.&&. course E.^. CourseShorthand E.==. E.val csh
-       E.&&. course E.^. CourseTerm E.==. E.val tid
-
-  return $ submission E.^. SubmissionId
-
-
-
-defaultLinks :: (MonadHandler m, HandlerSite m ~ UniWorX) => m [Nav]
-defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header.
-  [ return NavHeader
-      { navHeaderRole = NavHeaderSecondary
-      , navIcon       = IconMenuLogout
-      , navLink       = NavLink
-        { navLabel       = MsgMenuLogout
-        , navRoute       = AuthR LogoutR
-        , navAccess'     = is _Just <$> maybeAuthId
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      }
-  , return NavHeader
-      { navHeaderRole = NavHeaderSecondary
-      , navIcon       = IconMenuLogin
-      , navLink       = NavLink
-        { navLabel       = MsgMenuLogin
-        , navRoute       = AuthR LoginR
-        , navAccess'     = is _Nothing <$> maybeAuthId
-        , navType        = NavTypeLink { navModal = True }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      }
-  , return NavHeader
-      { navHeaderRole = NavHeaderSecondary
-      , navIcon       = IconMenuProfile
-      , navLink       = NavLink
-        { navLabel       = MsgMenuProfile
-        , navRoute       = ProfileR
-        , navAccess'     = is _Just <$> maybeAuthId
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      }
-  , do
-      mCurrentRoute <- getCurrentRoute
-
-      activeLang <- selectLanguage appLanguages
-
-      let navChildren = flip map (toList appLanguages) $ \lang -> NavLink
-            { navLabel       = MsgLanguage lang
-            , navRoute       = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ])
-            , navAccess'     = return True
-            , navType        = NavTypeButton
-              { navMethod = POST
-              , navData   = [(toPathPiece PostLanguage, lang)]
-              }
-            , navQuick'      = mempty
-            , navForceActive = lang == activeLang
-            }
-
-      guard $ length navChildren > 1
-
-      return NavHeaderContainer
-        { navHeaderRole = NavHeaderSecondary
-        , navLabel      = SomeMessage MsgMenuLanguage
-        , navIcon       = IconLanguage
-        , navChildren
-        }
-  , do
-      mCurrentRoute <- getCurrentRoute
-
-      return NavHeader
-        { navHeaderRole = NavHeaderSecondary
-        , navIcon       = IconMenuHelp
-        , navLink       = NavLink
-          { navLabel       = MsgMenuHelp
-          , navRoute       = (HelpR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ])
-          , navAccess'     = return True
-          , navType        = NavTypeLink { navModal = True }
-          , navQuick'      = mempty
-          , navForceActive = False
-          }
-        }
-  , return $ NavFooter NavLink
-      { navLabel       = MsgMenuDataProt
-      , navRoute       = LegalR :#: ("data-protection" :: Text)
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-  , return $ NavFooter NavLink
-      { navLabel       = MsgMenuTermsUse
-      , navRoute       = LegalR :#: ("terms-of-use" :: Text)
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-  , return $ NavFooter NavLink
-      { navLabel       = MsgMenuCopyright
-      , navRoute       = LegalR :#: ("copyright" :: Text)
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-  , return $ NavFooter NavLink
-      { navLabel       = MsgMenuImprint
-      , navRoute       = LegalR :#: ("imprint" :: Text)
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-  , return $ NavFooter NavLink
-      { navLabel       = MsgMenuInformation
-      , navRoute       = InfoR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-  , return $ NavFooter NavLink
-      { navLabel       = MsgMenuFaq
-      , navRoute       = FaqR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-  , return $ NavFooter NavLink
-      { navLabel       = MsgMenuGlossary
-      , navRoute       = GlossaryR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-  , return NavHeader
-      { navHeaderRole = NavHeaderPrimary
-      , navIcon       = IconMenuNews
-      , navLink       = NavLink
-        { navLabel       = MsgMenuNews
-        , navRoute       = NewsR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      }
-  , return NavHeader
-      { navHeaderRole = NavHeaderPrimary
-      , navIcon       = IconMenuCourseList
-      , navLink       = NavLink
-        { navLabel       = MsgMenuCourseList
-        , navRoute       = CourseListR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      }
-  , return NavHeader
-      { navHeaderRole = NavHeaderPrimary
-      , navIcon       = IconMenuCorrections
-      , navLink       = NavLink
-        { navLabel       = MsgMenuCorrections
-        , navRoute       = CorrectionsR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      }
-  , return NavHeader
-      { navHeaderRole = NavHeaderPrimary
-      , navIcon       = IconMenuExams
-      , navLink       = NavLink
-        { navLabel       = MsgMenuExamOfficeExams
-        , navRoute       = ExamOfficeR EOExamsR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      }
-  , return NavHeaderContainer
-      { navHeaderRole = NavHeaderPrimary
-      , navLabel      = SomeMessage MsgAdminHeading
-      , navIcon       = IconMenuAdmin
-      , navChildren   =
-          [ NavLink
-              { navLabel       = MsgMenuUsers
-              , navRoute       = UsersR
-              , navAccess'     = return True
-              , navType        = NavTypeLink { navModal = False }
-              , navQuick'      = mempty
-              , navForceActive = False
-              }
-          , NavLink
-              { navLabel       = MsgMenuSchoolList
-              , navRoute       = SchoolListR
-              , navAccess'     = return True
-              , navType        = NavTypeLink { navModal = False }
-              , navQuick'      = mempty
-              , navForceActive = False
-              }
-          , NavLink
-              { navLabel       = MsgAdminFeaturesHeading
-              , navRoute       = AdminFeaturesR
-              , navAccess'     = return True
-              , navType        = NavTypeLink { navModal = False }
-              , navQuick'      = mempty
-              , navForceActive = False
-              }
-          , NavLink
-              { navLabel       = MsgMenuMessageList
-              , navRoute       = MessageListR
-              , navAccess'     = return True
-              , navType        = NavTypeLink { navModal = False }
-              , navQuick'      = mempty
-              , navForceActive = False
-              }
-          , NavLink
-              { navLabel       = MsgMenuAdminErrMsg
-              , navRoute       = AdminErrMsgR
-              , navAccess'     = return True
-              , navType        = NavTypeLink { navModal = False }
-              , navQuick'      = mempty
-              , navForceActive = False
-              }
-          , NavLink
-              { navLabel       = MsgMenuAdminTokens
-              , navRoute       = AdminTokensR
-              , navAccess'     = return True
-              , navType        = NavTypeLink { navModal = False }
-              , navQuick'      = mempty
-              , navForceActive = False
-              }
-          , NavLink
-              { navLabel       = MsgMenuAdminCrontab
-              , navRoute       = AdminCrontabR
-              , navAccess'     = return True
-              , navType        = NavTypeLink { navModal = False }
-              , navQuick'      = mempty
-              , navForceActive = False
-              }
-          , NavLink
-              { navLabel       = MsgMenuAdminTest
-              , navRoute       = AdminTestR
-              , navAccess'     = return True
-              , navType        = NavTypeLink { navModal = False }
-              , navQuick'      = mempty
-              , navForceActive = False
-              }
-          ]
-      }
-  , return NavHeaderContainer
-      { navHeaderRole = NavHeaderPrimary
-      , navLabel      = SomeMessage (mempty :: Text)
-      , navIcon       = IconMenuExtra
-      , navChildren   =
-          [ NavLink
-              { navLabel       = MsgMenuCourseNew
-              , navRoute       = CourseNewR
-              , navAccess'     = return True
-              , navType        = NavTypeLink { navModal = False }
-              , navQuick'      = mempty
-              , navForceActive = False
-              }
-          , NavLink
-              { navLabel       = MsgMenuExternalExamList
-              , navRoute       = EExamListR
-              , navAccess'     = return True
-              , navType        = NavTypeLink { navModal = False }
-              , navQuick'      = mempty
-              , navForceActive = False
-              }
-          , NavLink
-              { navLabel       = MsgMenuTermShow
-              , navRoute       = TermShowR
-              , navAccess'     = return True
-              , navType        = NavTypeLink { navModal = False }
-              , navQuick'      = mempty
-              , navForceActive = False
-              }
-          , NavLink
-              { navLabel       = MsgMenuAllocationList
-              , navRoute       = AllocationListR
-              , navAccess'     = return True
-              , navType        = NavTypeLink { navModal = False }
-              , navQuick'      = mempty
-              , navForceActive = False
-              }
-          , NavLink
-              { navLabel       = MsgInfoLecturerTitle
-              , navRoute       = InfoLecturerR
-              , navAccess'     = hasWriteAccessTo CourseNewR
-              , navType        = NavTypeLink { navModal = False }
-              , navQuick'      = mempty
-              , navForceActive = False
-              }
-          ]
-      }
-  ]
-
-
-pageActions :: ( MonadHandler m
-               , HandlerSite m ~ UniWorX
-               , MonadCatch m
-               )
-            => Route UniWorX -> m [Nav]
-pageActions NewsR = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuOpenCourses
-      , navRoute       = (CourseListR, [("courses-openregistration", toPathPiece True)])
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuOpenAllocations
-      , navRoute       = (AllocationListR, [("allocations-active", toPathPiece True)])
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions (CourseR tid ssh csh CShowR) = do
-  materialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh MaterialListR
-  tutorialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CTutorialListR
-  sheetListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh SheetListR
-  examListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CExamListR
-  membersSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CUsersR
-
-  let examListBound :: Num a => a
-      examListBound = 4 -- guaranteed random; chosen by fair dice roll
-  examListExams <- liftHandler . runDB $ do
-    examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do
-      E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
-      E.where_ $ course   E.^. CourseTerm      E.==. E.val tid
-           E.&&. course   E.^. CourseSchool    E.==. E.val ssh
-           E.&&. course   E.^. CourseShorthand E.==. E.val csh
-      E.limit $ succ examListBound
-      return $ exam E.^. ExamName
-    return $ do
-      E.Value examn <- examNames
-      return NavLink
-        { navLabel       = examn
-        , navRoute       = CExamR tid ssh csh examn EShowR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = navQuick NavQuickViewFavourite
-        , navForceActive = False
-        }
-  let showExamList = length examListExams <= examListBound
-
-  let
-    navMembers = NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuCourseMembers
-        , navRoute       = CourseR tid ssh csh CUsersR
-        , navAccess' =
-            let courseWhere course = course <$ do
-                  E.where_ $ course E.^. CourseTerm      E.==. E.val tid
-                       E.&&. course E.^. CourseSchool    E.==. E.val ssh
-                       E.&&. course E.^. CourseShorthand E.==. E.val csh
-                hasParticipants = E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
-                  E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
-                  E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
-                  void $ courseWhere course
-                mayRegister = hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
-             in runDB $ mayRegister `or2M` hasParticipants
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = navQuick NavQuickViewFavourite
-        , navForceActive = False
-        }
-      , navChildren = membersSecondary
-      }
-  showMembers <- maybeT (return False) $ True <$ navAccess navMembers
-
-  return $
-    [ NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuMaterialList
-        , navRoute       = CourseR tid ssh csh MaterialListR
-        , navAccess' =
-            let lecturerAccess     = hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR  -- Always show for lecturers to create new material
-                materialAccess mnm = hasReadAccessTo  $ CMaterialR tid ssh csh mnm MShowR -- otherwise show only if the user can see at least one of the contents
-                existsVisible  = do
-                    matNames <- E.select . E.from $ \(course `E.InnerJoin` material) -> do
-                      E.on     $ course   E.^. CourseId   E.==.   material E.^. MaterialCourse
-                      E.where_ $ course   E.^. CourseTerm      E.==. E.val tid
-                          E.&&.  course   E.^. CourseSchool    E.==. E.val ssh
-                          E.&&.  course   E.^. CourseShorthand E.==. E.val csh
-                      return $ material E.^. MaterialName
-                    anyM matNames (materialAccess . E.unValue)
-             in runDB $ lecturerAccess `or2M` existsVisible
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = navQuick NavQuickViewFavourite
-        , navForceActive = False
-        }
-      , navChildren = materialListSecondary
-      }
-    , NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuSheetList
-        , navRoute       = CourseR tid ssh csh SheetListR
-        , navAccess' =
-            let lecturerAccess  = hasWriteAccessTo $ CourseR tid ssh csh SheetNewR  -- Always show for lecturers to create new sheets
-                sheetAccess shn = hasReadAccessTo  $ CSheetR tid ssh csh shn SShowR -- othwerwise show only if the user can see at least one of the contents
-                existsVisible  = do
-                    sheetNames <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
-                      E.on     $ course   E.^. CourseId   E.==.   sheet E.^. SheetCourse
-                      E.where_ $ course   E.^. CourseTerm      E.==. E.val tid
-                          E.&&.  course   E.^. CourseSchool    E.==. E.val ssh
-                          E.&&.  course   E.^. CourseShorthand E.==. E.val csh
-                      return $ sheet E.^. SheetName
-                    anyM sheetNames $ sheetAccess . E.unValue
-             in runDB $ lecturerAccess `or2M` existsVisible
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = navQuick NavQuickViewFavourite
-        , navForceActive = False
-        }
-      , navChildren = sheetListSecondary
-      }
-    , NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuTutorialList
-        , navRoute       = CourseR tid ssh csh CTutorialListR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = navQuick NavQuickViewFavourite
-        , navForceActive = False
-        }
-      , navChildren = tutorialListSecondary
-      }
-    , NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuExamList
-        , navRoute       = CourseR tid ssh csh CExamListR
-        , navAccess' =
-            let lecturerAccess   = hasWriteAccessTo $ CourseR tid ssh csh CExamNewR
-                examAccess examn = hasReadAccessTo  $ CExamR tid ssh csh examn EShowR
-                existsVisible = do
-                  examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do
-                    E.on     $ course   E.^. CourseId E.==. exam E.^. ExamCourse
-                    E.where_ $ course   E.^. CourseTerm      E.==. E.val tid
-                        E.&&.  course   E.^. CourseSchool    E.==. E.val ssh
-                        E.&&.  course   E.^. CourseShorthand E.==. E.val csh
-                    return $ exam E.^. ExamName
-                  anyM examNames $ examAccess . E.unValue
-             in runDB $ lecturerAccess `or2M` existsVisible
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = bool (navQuick NavQuickViewFavourite) mempty showExamList
-        , navForceActive = False
-        }
-      , navChildren = examListSecondary ++ guardOnM showExamList examListExams
-      }
-    , navMembers
-    ] ++ guardOnM (not showMembers) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- membersSecondary ] ++
-    [ NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuCourseCommunication
-        , navRoute       = CourseR tid ssh csh CCommR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = navQuick NavQuickViewFavourite
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-    , NavPageActionSecondary
-      { navLink = NavLink
-        { navLabel       = MsgMenuCourseExamOffice
-        , navRoute       = CourseR tid ssh csh CExamOfficeR
-        , navAccess' = do
-            uid <- requireAuthId
-            runDB $ do
-              cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-              E.selectExists $ do
-                (_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid)
-                E.where_ $ E.not_ isForced
-        , navType        = NavTypeLink { navModal = True }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      }
-    , NavPageActionSecondary
-      { navLink = NavLink
-        { navLabel       = MsgMenuCourseEdit
-        , navRoute       = CourseR tid ssh csh CEditR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      }
-    , NavPageActionSecondary
-      { navLink = NavLink
-        { navLabel       = MsgMenuCourseClone
-        , navRoute       = ( CourseNewR
-                           , [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)]
-                           )
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      }
-    , NavPageActionSecondary
-      { navLink = NavLink
-        { navLabel       = MsgMenuCourseDelete
-        , navRoute       = CourseR tid ssh csh CDeleteR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      }
-    ]
-pageActions (ExamOfficeR EOExamsR) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuExamOfficeFields
-      , navRoute       = ExamOfficeR EOFieldsR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = True }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuExamOfficeUsers
-      , navRoute       = ExamOfficeR EOUsersR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = True }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions SchoolListR = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuSchoolNew
-      , navRoute       = SchoolNewR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions UsersR = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuLecturerInvite
-      , navRoute       = AdminNewFunctionaryInviteR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = True }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuUserAdd
-      , navRoute       = AdminUserAddR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = True }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions (AdminUserR cID) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuUserNotifications
-      , navRoute       = UserNotificationR cID
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = True }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuUserPassword
-      , navRoute       = UserPasswordR cID
-      , navAccess' = do
-          uid <- decrypt cID
-          User{userAuthentication} <- runDB $ get404 uid
-          return $ is _AuthPWHash userAuthentication
-      , navType        = NavTypeLink { navModal = True }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions InfoR = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgInfoLecturerTitle
-      , navRoute       = InfoLecturerR
-      , navAccess'     = hasWriteAccessTo CourseNewR
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuLegal
-      , navRoute       = LegalR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuFaq
-      , navRoute       = FaqR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuGlossary
-      , navRoute       = GlossaryR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions VersionR = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgInfoLecturerTitle
-      , navRoute       = InfoLecturerR
-      , navAccess'     = hasWriteAccessTo CourseNewR
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuLegal
-      , navRoute       = LegalR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuFaq
-      , navRoute       = FaqR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuGlossary
-      , navRoute       = GlossaryR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions HealthR = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuInstance
-      , navRoute       = InstanceR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions InstanceR = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuHealth
-      , navRoute       = HealthR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions HelpR = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuFaq
-      , navRoute       = FaqR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgInfoLecturerTitle
-      , navRoute       = InfoLecturerR
-      , navAccess'     = hasWriteAccessTo CourseNewR
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = do
-        (section, navLabel) <-
-          [ ("courses", MsgInfoLecturerCourses)
-          , ("exercises", MsgInfoLecturerExercises)
-          , ("tutorials", MsgInfoLecturerTutorials)
-          , ("exams", MsgInfoLecturerExams)
-          , ("allocations", MsgInfoLecturerAllocations)
-          ] :: [(Text, UniWorXMessage)]
-        return NavLink
-          { navLabel
-          , navRoute       = InfoLecturerR :#: section
-          , navAccess'     = return True
-          , navType        = NavTypeLink { navModal = False }
-          , navQuick'      = mempty
-          , navForceActive = False
-          }
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuGlossary
-      , navRoute       = GlossaryR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions ProfileR = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuProfileData
-      , navRoute       = ProfileDataR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuAuthPreds
-      , navRoute       = AuthPredsR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = True }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgCsvOptions
-      , navRoute       = CsvOptionsR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = True }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions TermShowR = do
-  participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
-  return
-    [ NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuTermCreate
-        , navRoute       = TermEditR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-    , NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuParticipantsList
-        , navRoute       = ParticipantsListR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = participantsSecondary
-      }
-    ]
-pageActions (AllocationR tid ssh ash AShowR) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuAllocationInfo
-      , navRoute       = InfoAllocationR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = True }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuAllocationUsers
-      , navRoute       = AllocationR tid ssh ash AUsersR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuAllocationCompute
-      , navRoute       = AllocationR tid ssh ash AComputeR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions (AllocationR tid ssh ash AUsersR) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuAllocationPriorities
-      , navRoute       = AllocationR tid ssh ash APriosR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuAllocationCompute
-      , navRoute       = AllocationR tid ssh ash AComputeR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions CourseListR = do
-  participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
-  return
-    [ NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuCourseNew
-        , navRoute       = CourseNewR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-    , NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuAllocationList
-        , navRoute       = AllocationListR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-    , NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuParticipantsList
-        , navRoute       = ParticipantsListR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = participantsSecondary
-      }
-    ]
-pageActions CourseNewR = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgInfoLecturerTitle
-      , navRoute       = InfoLecturerR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions (CourseR tid ssh csh CCorrectionsR) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuCorrectionsAssign
-      , navRoute       = CourseR tid ssh csh CAssignR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuCorrectionsOwn
-      , navRoute       = ( CorrectionsR
-                         , [ ("corrections-term", toPathPiece tid)
-                           , ("corrections-school", toPathPiece ssh)
-                           , ("corrections-course", toPathPiece csh)
-                           ]
-                         )
-      , navAccess' = do
-          muid <- maybeAuthId
-          case muid of
-            Nothing -> return False
-            (Just uid) -> do
-              runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do
-                E.on $ submission E.^. SubmissionSheet E.==. sheet  E.^. SheetId
-                E.on $ sheet      E.^. SheetCourse     E.==. course E.^. CourseId
-                E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
-                  E.&&. course E.^. CourseTerm      E.==. E.val tid
-                  E.&&. course E.^. CourseSchool    E.==. E.val ssh
-                  E.&&. course E.^. CourseShorthand E.==. E.val csh
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = navQuick NavQuickViewPageActionSecondary
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions (CourseR tid ssh csh SheetListR) = do
-  correctionsSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CCorrectionsR
-
-  let
-    navCorrections = NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuSubmissions
-        , navRoute       = CourseR tid ssh csh CCorrectionsR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
-        , navForceActive = False
-        }
-      , navChildren = correctionsSecondary
-      }
-  showCorrections <- maybeT (return False) $ True <$ navAccess navCorrections
-
-  return $
-    [ NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuSheetCurrent
-        , navRoute       = CourseR tid ssh csh SheetCurrentR
-        , navAccess' =
-            runDB . maybeT (return False) $ do
-              void . MaybeT $ sheetCurrent tid ssh csh
-              return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-    , NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuSheetOldUnassigned
-        , navRoute       = CourseR tid ssh csh SheetOldUnassignedR
-        , navAccess' =
-            runDB . maybeT (return False) $ do
-              void . MaybeT $ sheetOldUnassigned tid ssh csh
-              return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-    , navCorrections
-    ] ++ guardOnM (not showCorrections) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- correctionsSecondary ] ++
-    [ NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuSheetNew
-        , navRoute       = CourseR tid ssh csh SheetNewR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-    ]
-pageActions (CourseR tid ssh csh CUsersR) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuCourseAddMembers
-      , navRoute       = CourseR tid ssh csh CAddUserR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = True }
-      , navQuick'      = navQuick NavQuickViewPageActionSecondary
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuCourseApplications
-      , navRoute       = CourseR tid ssh csh CApplicationsR
-      , navAccess' =
-          let courseWhere course = course <$ do
-                E.where_ $ course E.^. CourseTerm      E.==. E.val tid
-                     E.&&. course E.^. CourseSchool    E.==. E.val ssh
-                     E.&&. course E.^. CourseShorthand E.==. E.val csh
-              existsApplications = E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do
-                E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
-                void $ courseWhere course
-              courseApplications = fmap (any E.unValue) . E.select . E.from $ \course -> do
-                void $ courseWhere course
-                return $ course E.^. CourseApplicationsRequired
-              courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do
-                E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
-                void $ courseWhere course
-           in runDB $ courseAllocation `or2M` courseApplications `or2M` existsApplications
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions (CourseR tid ssh csh MaterialListR) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuMaterialNew
-      , navRoute       = CourseR tid ssh csh MaterialNewR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = navQuick NavQuickViewPageActionSecondary
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions (CMaterialR tid ssh csh mnm MShowR) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuMaterialEdit
-      , navRoute       = CMaterialR tid ssh csh mnm MEditR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionSecondary
-    { navLink = NavLink
-      { navLabel       = MsgMenuMaterialDelete
-      , navRoute       = CMaterialR tid ssh csh mnm MDelR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = True }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    }
-  ]
-pageActions (CourseR tid ssh csh CTutorialListR) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuTutorialNew
-      , navRoute       = CourseR tid ssh csh CTutorialNewR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = navQuick NavQuickViewPageActionSecondary
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions (CTutorialR tid ssh csh tutn TEditR) = return
-  [ NavPageActionSecondary
-    { navLink = NavLink
-      { navLabel       = MsgMenuTutorialDelete
-      , navRoute       = CTutorialR tid ssh csh tutn TDeleteR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    }
-  ]
-pageActions (CTutorialR tid ssh csh tutn TUsersR) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuTutorialComm
-      , navRoute       = CTutorialR tid ssh csh tutn TCommR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuTutorialEdit
-      , navRoute       = CTutorialR tid ssh csh tutn TEditR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionSecondary
-    { navLink = NavLink
-      { navLabel       = MsgMenuTutorialDelete
-      , navRoute       = CTutorialR tid ssh csh tutn TDeleteR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    }
-  ]
-pageActions (CourseR tid ssh csh CExamListR) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuExamNew
-      , navRoute       = CourseR tid ssh csh CExamNewR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = navQuick NavQuickViewPageActionSecondary
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions (CExamR tid ssh csh examn EShowR) = do
-  usersSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CExamR tid ssh csh examn EUsersR
-
-  return
-    [ NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuExamEdit
-        , navRoute       = CExamR tid ssh csh examn EEditR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-    , NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuExamUsers
-        , navRoute       = CExamR tid ssh csh examn EUsersR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = usersSecondary
-      }
-    , NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuExamGrades
-        , navRoute       = CExamR tid ssh csh examn EGradesR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-    , NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuExamCorrect
-        , navRoute       = CExamR tid ssh csh examn ECorrectR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-    ]
-pageActions (CExamR tid ssh csh examn ECorrectR) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuExamUsers
-      , navRoute       = CExamR tid ssh csh examn EUsersR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuExamGrades
-      , navRoute       = CExamR tid ssh csh examn EGradesR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionSecondary
-    { navLink = NavLink
-      { navLabel       = MsgMenuExamEdit
-      , navRoute       = CExamR tid ssh csh examn EEditR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    }
-  ]
-pageActions (CExamR tid ssh csh examn EUsersR) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuExamAddMembers
-      , navRoute       = CExamR tid ssh csh examn EAddUserR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = True }
-      , navQuick'      = navQuick NavQuickViewPageActionSecondary
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuExamGrades
-      , navRoute       = CExamR tid ssh csh examn EGradesR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuExamCorrect
-      , navRoute       = CExamR tid ssh csh examn ECorrectR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions (CExamR tid ssh csh examn EGradesR) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuExamUsers
-      , navRoute       = CExamR tid ssh csh examn EUsersR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = navQuick NavQuickViewPageActionSecondary
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuExamCorrect
-      , navRoute       = CExamR tid ssh csh examn ECorrectR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions (CSheetR tid ssh csh shn SShowR) = do
-  subsSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CSheetR tid ssh csh shn SSubsR
-  let
-    navSubmissions = NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuSubmissions
-        , navRoute       = CSheetR tid ssh csh shn SSubsR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = subsSecondary
-      }
-  showSubmissions <- maybeT (return False) $ True <$ navAccess navSubmissions
-
-  return $
-    [ NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuSubmissionOwn
-        , navRoute       = CSheetR tid ssh csh shn SubmissionOwnR
-        , navAccess' =
-            runDB . maybeT (return False) $ do
-              uid <- MaybeT $ liftHandler maybeAuthId
-              submissions <- lift $ submissionList tid csh shn uid
-              guard . not $ null submissions
-              return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-    , navSubmissions
-    ] ++ guardOnM (not showSubmissions) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- subsSecondary ] ++
-    [ NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuSheetPersonalisedFiles
-        , navRoute       = CSheetR tid ssh csh shn SPersonalFilesR
-        , navAccess'     =
-            let onlyPersonalised = fmap (maybe False $ not . E.unValue) . E.selectMaybe . E.from $ \(sheet `E.InnerJoin` course) -> do
-                  E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
-                  E.where_$ sheet E.^. SheetName E.==. E.val shn
-                      E.&&. course E.^. CourseTerm E.==. E.val tid
-                      E.&&. course E.^. CourseSchool E.==. E.val ssh
-                      E.&&. course E.^. CourseShorthand E.==. E.val csh
-                  return $ sheet E.^. SheetAllowNonPersonalisedSubmission
-                hasPersonalised = E.selectExists . E.from $ \(sheet `E.InnerJoin` course `E.InnerJoin` personalisedSheetFile) -> do
-                  E.on $ personalisedSheetFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
-                  E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
-                  E.where_$ sheet E.^. SheetName E.==. E.val shn
-                      E.&&. course E.^. CourseTerm E.==. E.val tid
-                      E.&&. course E.^. CourseSchool E.==. E.val ssh
-                      E.&&. course E.^. CourseShorthand E.==. E.val csh
-             in runDB $ or2M onlyPersonalised hasPersonalised
-        , navType        = NavTypeLink { navModal = True }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-    , NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuSheetEdit
-        , navRoute       = CSheetR tid ssh csh shn SEditR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-    , NavPageActionSecondary
-      { navLink = NavLink
-        { navLabel       = MsgMenuSheetClone
-        , navRoute       = (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)])
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      }
-    , NavPageActionSecondary
-      { navLink = NavLink
-        { navLabel       = MsgMenuSheetDelete
-        , navRoute       = CSheetR tid ssh csh shn SDelR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      }
-    ]
-pageActions (CSheetR tid ssh csh shn SSubsR) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuSubmissionNew
-      , navRoute       = CSheetR tid ssh csh shn SubmissionNewR
-      , navAccess' =
-          let submissionAccess = hasWriteAccessTo $ CSheetR tid ssh csh shn SSubsR
-              hasNoSubmission = maybeT (return False) $ do
-                uid <- MaybeT $ liftHandler maybeAuthId
-                submissions <- lift $ submissionList tid csh shn uid
-                guard $ null submissions
-                return True
-           in runDB $ hasNoSubmission `or2M` submissionAccess
-      , navType        = NavTypeLink { navModal = True }
-      , navQuick'      = navQuick NavQuickViewPageActionSecondary
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuCorrectionsOwn
-      , navRoute       = ( CorrectionsR
-                         , [ ("corrections-term", toPathPiece tid)
-                           , ("corrections-school", toPathPiece ssh)
-                           , ("corrections-course", toPathPiece csh)
-                           , ("corrections-sheet", toPathPiece shn)
-                           ]
-                         )
-      , navAccess'     = (== Authorized) <$> evalAccessCorrector tid ssh csh
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = navQuick NavQuickViewPageActionSecondary
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuCorrectionsAssign
-      , navRoute       = CSheetR tid ssh csh shn SAssignR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = navQuick NavQuickViewPageActionSecondary
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuCorrection
-      , navRoute       = CSubmissionR tid ssh csh shn cid CorrectionR
-      , navAccess'     = hasWriteAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgCorrectorAssignTitle
-      , navRoute       = CSubmissionR tid ssh csh shn cid SubAssignR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = True }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionSecondary
-    { navLink = NavLink
-      { navLabel       = MsgMenuSubmissionDelete
-      , navRoute       = CSubmissionR tid ssh csh shn cid SubDelR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    }
-  ]
-pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgCorrectorAssignTitle
-      , navRoute       = CSubmissionR tid ssh csh shn cid SubAssignR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = True }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionSecondary
-    { navLink = NavLink
-      { navLabel       = MsgMenuSubmissionDelete
-      , navRoute       = CSubmissionR tid ssh csh shn cid SubDelR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    }
-  ]
-pageActions (CourseR tid ssh csh CApplicationsR) = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuCourseApplicationsFiles
-      , navRoute       = CourseR tid ssh csh CAppsFilesR
-      , navAccess' =
-          let appAccess (E.Value appId) = do
-                cID <- encrypt appId
-                hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
-              appSource = E.selectSource . E.from $ \(course `E.InnerJoin` courseApplication) -> do
-                E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
-                E.where_ $ course E.^. CourseTerm E.==. E.val tid
-                     E.&&. course E.^. CourseSchool E.==. E.val ssh
-                     E.&&. course E.^. CourseShorthand E.==. E.val csh
-                E.where_ . E.exists . E.from $ \courseApplicationFile ->
-                  E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. courseApplication E.^. CourseApplicationId
-                return $ courseApplication E.^. CourseApplicationId
-           in runDB . runConduit $ appSource .| anyMC appAccess
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuCourseMembers
-      , navRoute       = CourseR tid ssh csh CUsersR
-      , navAccess' =
-          runDB $ do
-            cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-            exists [ CourseParticipantCourse ==. cid ]
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions CorrectionsR = return
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuCorrectionsDownload
-      , navRoute       = CorrectionsDownloadR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = navQuick NavQuickViewPageActionSecondary
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuCorrectionsUpload
-      , navRoute       = CorrectionsUploadR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = True }
-      , navQuick'      = navQuick NavQuickViewPageActionSecondary
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuCorrectionsCreate
-      , navRoute       = CorrectionsCreateR
-      , navAccess'     = runDB . maybeT (return False) $ do
-          uid <- MaybeT $ liftHandler maybeAuthId
-          sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
-            E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
-            let
-              isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_
-                    $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
-                E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
-              isLecturer = E.exists . E.from $ \lecturer -> E.where_
-                    $ lecturer E.^. LecturerUser E.==. E.val uid
-                E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
-            E.where_ $ isCorrector' E.||. isLecturer
-            return $ sheet E.^. SheetSubmissionMode
-          return $ orOf (traverse . _Value . _submissionModeCorrector) sheets
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = navQuick NavQuickViewPageActionSecondary
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuCorrectionsGrade
-      , navRoute       = CorrectionsGradeR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions CorrectionsGradeR = do
-  correctionsSecondary <- pageQuickActions NavQuickViewPageActionSecondary CorrectionsR
-  return
-    [ NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuCorrections
-        , navRoute       = CorrectionsR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = correctionsSecondary
-      }
-    ]
-pageActions EExamListR = return
-  [ NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuExternalExamNew
-        , navRoute       = EExamNewR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-  ]
-pageActions (EExamR tid ssh coursen examn EEShowR) = return
-  [ NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuExternalExamEdit
-        , navRoute       = EExamR tid ssh coursen examn EEEditR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-  , NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuExternalExamUsers
-        , navRoute       = EExamR tid ssh coursen examn EEUsersR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-  , NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuExternalExamGrades
-        , navRoute       = EExamR tid ssh coursen examn EEGradesR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-  ]
-pageActions (EExamR tid ssh coursen examn EEGradesR) = return
-  [ NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuExternalExamUsers
-        , navRoute       = EExamR tid ssh coursen examn EEUsersR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-  , NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuExternalExamEdit
-        , navRoute       = EExamR tid ssh coursen examn EEEditR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-  ]
-pageActions (EExamR tid ssh coursen examn EEUsersR) = return
-  [ NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuExternalExamGrades
-        , navRoute       = EExamR tid ssh coursen examn EEGradesR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-  , NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgMenuExternalExamEdit
-        , navRoute       = EExamR tid ssh coursen examn EEEditR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = False }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-  ]
-pageActions ParticipantsListR = return
-  [ NavPageActionPrimary
-      { navLink = NavLink
-        { navLabel       = MsgCsvOptions
-        , navRoute       = CsvOptionsR
-        , navAccess'     = return True
-        , navType        = NavTypeLink { navModal = True }
-        , navQuick'      = mempty
-        , navForceActive = False
-        }
-      , navChildren = []
-      }
-
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuParticipantsIntersect
-      , navRoute       = ParticipantsIntersectR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False}
-      , navQuick'      = navQuick NavQuickViewPageActionSecondary
-      , navForceActive = False
-      }
-    , navChildren = []
-    }
-  ]
-pageActions _ = return []
-
-pageQuickActions :: ( MonadCatch m
-                    , MonadHandler m
-                    , HandlerSite m ~ UniWorX
-                    )
-                 => NavQuickView -> Route UniWorX -> m [NavLink]
-pageQuickActions qView route = do
-  items'' <- pageActions route
-  items' <- catMaybes <$> mapM (runMaybeT . navAccess) items''
-  filterM navLinkAccess $ items' ^.. typesUsing @NavChildren @NavLink . filtered (getAny . ($ qView) . navQuick')
-
-
-i18nHeading :: (MonadWidget m, RenderMessage site msg, HandlerSite m ~ site) => msg -> m ()
-i18nHeading msg = liftWidget $ toWidget =<< getMessageRender <*> pure msg
-
--- | only used in defaultLayout; better use siteLayout instead!
-pageHeading :: Route UniWorX -> Maybe Widget
-pageHeading (AuthR _)
-  = Just $ i18nHeading MsgLoginHeading
-pageHeading NewsR
-  = Just $ i18nHeading MsgNewsHeading
-pageHeading UsersR
-  = Just $ i18nHeading MsgUsers
-pageHeading (AdminUserR _)
-  = Just $ i18nHeading MsgAdminUserHeading
-pageHeading AdminTestR
-  = Just [whamlet|Internal Code Demonstration Page|]
-pageHeading AdminErrMsgR
-  = Just $ i18nHeading MsgErrMsgHeading
-
-pageHeading InfoR
-  = Just $ i18nHeading MsgInfoHeading
-pageHeading LegalR
-  = Just $ i18nHeading MsgLegalHeading
-pageHeading VersionR
-  = Just $ i18nHeading MsgVersionHeading
-
-pageHeading HelpR
-  = Just $ i18nHeading MsgHelpRequest
-
-pageHeading ProfileR
-  = Just $ i18nHeading MsgProfileHeading
-pageHeading ProfileDataR
-  = Just $ i18nHeading MsgProfileDataHeading
-
-pageHeading TermShowR
-  = Just $ i18nHeading MsgTermsHeading
-pageHeading TermCurrentR
-  = Just $ i18nHeading MsgTermCurrent
-pageHeading TermEditR
-  = Just $ i18nHeading MsgTermEditHeading
-pageHeading (TermEditExistR tid)
-  = Just $ i18nHeading $ MsgTermEditTid tid
-pageHeading (TermCourseListR tid)
-  = Just . i18nHeading . MsgTermCourseListHeading $ tid
-pageHeading (TermSchoolCourseListR tid ssh)
-  = Just $ do
-      School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
-      i18nHeading $ MsgTermSchoolCourseListHeading tid school
-
-pageHeading CourseListR
-  = Just $ i18nHeading MsgCourseListTitle
-pageHeading CourseNewR
-  = Just $ i18nHeading MsgCourseNewHeading
-pageHeading (CourseR tid ssh csh CShowR)
-  = Just $ do
-    Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
-    toWidget courseName
---          (CourseR tid csh CRegisterR) -- just for POST
-pageHeading (CourseR tid ssh csh CEditR)
-  = Just $ i18nHeading $ MsgCourseEditHeading tid ssh csh
-pageHeading (CourseR tid ssh csh CCorrectionsR)
-  = Just $ i18nHeading $ MsgSubmissionsCourse tid ssh csh
-pageHeading (CourseR tid ssh csh SheetListR)
-  = Just $ i18nHeading $ MsgSheetList tid ssh csh
-pageHeading (CourseR tid ssh csh SheetNewR)
-  = Just $ i18nHeading $ MsgSheetNewHeading tid ssh csh
-pageHeading (CSheetR tid ssh csh shn SShowR)
-  = Just $ i18nHeading $ MsgSheetTitle tid ssh csh shn
-  -- = Just $ i18nHeading $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity
-pageHeading (CSheetR tid ssh csh shn SEditR)
-  = Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn
-pageHeading (CSheetR tid ssh csh shn SDelR)
-  = Just $ i18nHeading $ MsgSheetDelHead tid ssh csh shn
-pageHeading (CSheetR _tid _ssh _csh shn SSubsR)
-  = Just $ i18nHeading $ MsgSubmissionsSheet shn
-pageHeading (CSheetR tid ssh csh shn SubmissionNewR)
-  = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn
-pageHeading (CSheetR tid ssh csh shn SubmissionOwnR)
-  = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn
-pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one!
-  = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn
---          (CSubmissionR tid csh shn cid SubArchiveR) -- just a download
-pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR)
-  = Just $ i18nHeading $ MsgCorrectionHead tid ssh csh shn cid
---          (CSubmissionR tid csh shn cid SubDownloadR) -- just a download
---          (CSheetR tid ssh csh shn SFileR) -- just for Downloads
-
-pageHeading CorrectionsR
-  = Just $ i18nHeading MsgCorrectionsTitle
-pageHeading CorrectionsUploadR
-  = Just $ i18nHeading MsgCorrUpload
-pageHeading CorrectionsCreateR
-  = Just $ i18nHeading MsgCorrCreate
-pageHeading CorrectionsGradeR
-  = Just $ i18nHeading MsgCorrGrade
-pageHeading (MessageR _)
-  = Just $ i18nHeading MsgSystemMessageHeading
-pageHeading MessageListR
-  = Just $ i18nHeading MsgSystemMessageListHeading
-
--- TODO: add headings for more single course- and single term-pages
-pageHeading _
-  = Nothing
-
-
-routeNormalizers :: [Route UniWorX -> WriterT Any DB (Route UniWorX)]
-routeNormalizers =
-  [ normalizeRender
-  , ncSchool
-  , ncAllocation
-  , ncCourse
-  , ncSheet
-  , ncMaterial
-  , ncTutorial
-  , ncExam
-  , ncExternalExam
-  , verifySubmission
-  , verifyCourseApplication
-  , verifyCourseNews
-  ]
-  where
-    normalizeRender :: Route UniWorX -> WriterT Any DB (Route UniWorX)
-    normalizeRender route = route <$ do
-      YesodRequest{..} <- liftHandler getRequest
-      let original = (W.pathInfo reqWaiRequest, reqGetParams)
-          rendered = renderRoute route
-      if
-        | (isSuffixOf `on` fst) original rendered -> do -- FIXME: this breaks when subsite prefixes are dynamic
-            $logDebugS "normalizeRender" [st|#{tshow rendered} matches #{tshow original}|]
-        | otherwise -> do
-            $logDebugS "normalizeRender" [st|Redirecting because #{tshow rendered} does not match #{tshow original}|]
-            tell $ Any True
-
-    maybeOrig :: (Route UniWorX -> MaybeT (WriterT Any DB) (Route UniWorX))
-              -> Route UniWorX -> WriterT Any DB (Route UniWorX)
-    maybeOrig f route = maybeT (return route) $ f route
-
-    caseChanged :: (Eq a, Show a) => CI a -> CI a -> MaybeT (WriterT Any DB) ()
-    caseChanged a b
-      | ((/=) `on` CI.original) a b = do
-          $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
-          tell $ Any True
-      | otherwise                   = return ()
-
-    ncSchool = maybeOrig . typesUsing @RouteChildren @SchoolId $ \ssh -> $cachedHereBinary ssh $ do
-      let schoolShort :: SchoolShorthand
-          schoolShort = unSchoolKey ssh
-      Entity ssh' _  <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
-      (caseChanged `on` unSchoolKey) ssh ssh'
-      return ssh'
-    ncAllocation = maybeOrig $ \route -> do
-      AllocationR tid ssh ash _ <- return route
-      Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . lift . getBy $ TermSchoolAllocationShort tid ssh ash
-      caseChanged ash allocationShorthand
-      return $ route & typesUsing @RouteChildren @AllocationShorthand . filtered (== ash) .~ allocationShorthand
-    ncCourse = maybeOrig $ \route -> do
-      CourseR tid ssh csh _ <- return route
-      Entity _ Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
-      caseChanged csh courseShorthand
-      return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand
-    ncSheet = maybeOrig $ \route -> do
-      CSheetR tid ssh csh shn _ <- return route
-      cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
-      Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn
-      caseChanged shn sheetName
-      return $ route & typesUsing @RouteChildren @SheetName . filtered (== shn) .~ sheetName
-    ncMaterial = maybeOrig $ \route -> do
-      CMaterialR tid ssh csh mnm _ <- return route
-      cid <- MaybeT  . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
-      Entity _ Material{..} <- MaybeT . $cachedHereBinary (cid, mnm) . lift . getBy $ UniqueMaterial cid mnm
-      caseChanged mnm materialName
-      return $ route & typesUsing @RouteChildren @MaterialName . filtered (== mnm) .~ materialName
-    ncTutorial = maybeOrig $ \route -> do
-      CTutorialR tid ssh csh tutn _ <- return route
-      cid <- MaybeT  . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
-      Entity _ Tutorial{..} <- MaybeT . $cachedHereBinary (cid, tutn) . lift . getBy $ UniqueTutorial cid tutn
-      caseChanged tutn tutorialName
-      return $ route & typesUsing @RouteChildren @TutorialName . filtered (== tutn) .~ tutorialName
-    ncExam = maybeOrig $ \route -> do
-      CExamR tid ssh csh examn _ <- return route
-      cid <- MaybeT  . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
-      Entity _ Exam{..} <- MaybeT . $cachedHereBinary (cid, examn) . lift . getBy $ UniqueExam cid examn
-      caseChanged examn examName
-      return $ route & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ examName
-    ncExternalExam = maybeOrig $ \route -> do
-      EExamR tid ssh coursen examn _ <- return route
-      Entity _ ExternalExam{..} <- MaybeT . $cachedHereBinary (tid, ssh, coursen, examn) . lift . getBy $ UniqueExternalExam tid ssh coursen examn
-      caseChanged coursen externalExamCourseName
-      caseChanged examn externalExamExamName
-      return $ route
-        & typesUsing @RouteChildren @CourseName . filtered (== coursen) .~ externalExamCourseName
-        & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ externalExamExamName
-    verifySubmission = maybeOrig $ \route -> do
-      CSubmissionR _tid _ssh _csh _shn cID sr <- return route
-      sId <- $cachedHereBinary cID $ decrypt cID
-      Submission{submissionSheet} <- MaybeT . $cachedHereBinary cID . lift $ get sId
-      Sheet{sheetCourse, sheetName} <- MaybeT . $cachedHereBinary submissionSheet . lift $ get submissionSheet
-      Course{courseTerm, courseSchool, courseShorthand} <- MaybeT . $cachedHereBinary sheetCourse . lift $ get sheetCourse
-      let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
-      tell . Any $ route /= newRoute
-      return newRoute
-    verifyCourseApplication = maybeOrig $ \route -> do
-      CApplicationR _tid _ssh _csh cID sr <- return route
-      aId <- decrypt cID
-      CourseApplication{courseApplicationCourse} <- lift . lift $ get404 aId
-      Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseApplicationCourse
-      let newRoute = CApplicationR courseTerm courseSchool courseShorthand cID sr
-      tell . Any $ route /= newRoute
-      return newRoute
-    verifyCourseNews = maybeOrig $ \route -> do
-      CNewsR _tid _ssh _csh cID sr <- return route
-      aId <- decrypt cID
-      CourseNews{courseNewsCourse} <- lift . lift $ get404 aId
-      Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseNewsCourse
-      let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr
-      tell . Any $ route /= newRoute
-      return newRoute
-
-
-runSqlPoolRetry :: forall m a backend.
-                   ( MonadUnliftIO m, BackendCompatible SqlBackend backend
-                   , MonadLogger m, MonadMask m
-                   )
-                => ReaderT backend m a
-                -> Pool backend
-                -> m a
-runSqlPoolRetry action pool = do
-  let policy = Retry.fullJitterBackoff 1e3 & Retry.limitRetriesByCumulativeDelay 10e6
-      handlers = Retry.skipAsyncExceptions `snoc` Retry.logRetries suggestRetry logRetry
-        where suggestRetry :: IOException -> m Bool
-              suggestRetry ioExc = return $
-                   ioeGetErrorType ioExc == OtherError
-                && ioeGetLocation ioExc == "libpq"
-              logRetry :: forall e.
-                          Exception e
-                       => Bool -- ^ Will retry
-                       -> e
-                       -> Retry.RetryStatus
-                       -> m ()
-              logRetry shouldRetry@False err status = $logErrorS "runSqlPoolRetry" . pack $ Retry.defaultLogMsg shouldRetry err status
-              logRetry shouldRetry@True  err status = $logWarnS "runSqlPoolRetry" . pack $ Retry.defaultLogMsg shouldRetry err status
-
-  Retry.recovering policy handlers $ \Retry.RetryStatus{..} -> do
-    $logDebugS "runSqlPoolRetry" $ "rsIterNumber = " <> tshow rsIterNumber
-    runSqlPool action pool
-
-runDBRead :: ReaderT SqlReadBackend Handler a -> Handler a
-runDBRead action = do
-  $logDebugS "YesodPersist" "runDBRead"
-  runSqlPoolRetry (withReaderT SqlReadBackend action) . appConnPool =<< getYesod
-
--- How to run database actions.
-instance YesodPersist UniWorX where
-    type YesodPersistBackend UniWorX = SqlBackend
-    runDB action = do
-      -- stack <- liftIO currentCallStack
-      -- $logDebugS "YesodPersist" . unlines $ "runDB" : map pack stack
-      $logDebugS "YesodPersist" "runDB"
-      dryRun <- isDryRun
-      let action'
-            | dryRun = action <* transactionUndo
-            | otherwise = action
-
-      runSqlPoolRetry action' . appConnPool =<< getYesod
-
-instance YesodPersistRunner UniWorX where
-    getDBRunner = do
-      (DBRunner{..}, cleanup) <- defaultGetDBRunner appConnPool
-      return . (, cleanup) $ DBRunner (\action -> do
-                                          dryRun <- isDryRun
-                                          let action'
-                                                | dryRun = action <* transactionUndo
-                                                | otherwise = action
-                                          $logDebugS "YesodPersist" "runDBRunner"
-                                          runDBRunner action'
-                                      )
-
-data CampusUserConversionException
-  = CampusUserInvalidIdent
-  | CampusUserInvalidEmail
-  | CampusUserInvalidDisplayName
-  | CampusUserInvalidGivenName
-  | CampusUserInvalidSurname
-  | CampusUserInvalidTitle
-  | CampusUserInvalidMatriculation
-  | CampusUserInvalidSex
-  | CampusUserInvalidFeaturesOfStudy Text
-  | CampusUserInvalidAssociatedSchools Text
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
-  deriving anyclass (Exception)
-
-_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode
-_upsertCampusUserMode mMode cs@Creds{..}
-  | credsPlugin == "dummy"    = setMode <$> mMode (UpsertCampusUserDummy $ CI.mk credsIdent)
-  | credsPlugin `elem` others = setMode <$> mMode (UpsertCampusUserOther $ CI.mk credsIdent)
-  | otherwise                 = setMode <$> mMode  UpsertCampusUser
-  where
-    setMode UpsertCampusUser
-      = cs{ credsPlugin = "LDAP" }
-    setMode (UpsertCampusUserDummy ident)
-      = cs{ credsPlugin = "dummy", credsIdent = CI.original ident }
-    setMode (UpsertCampusUserOther ident)
-      = cs{ credsPlugin = bool (NonEmpty.head others) credsPlugin (credsPlugin `elem` others), credsIdent = CI.original ident }
-
-    others = "PWHash" :| []
-
-upsertCampusUser :: UpsertCampusUserMode -> Ldap.AttrList [] -> DB (Entity User)
-upsertCampusUser plugin ldapData = do
-  now <- liftIO getCurrentTime
-  UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
-
-  let
-    userIdent''         = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ]
-    userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ]
-    userEmail'          = fold $ do
-      k' <- toList ldapUserEmail
-      (k, v) <- ldapData
-      guard $ k' == k
-      return v
-    userDisplayName''   = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName   ]
-    userFirstName'      = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName     ]
-    userSurname'        = fold [ v | (k, v) <- ldapData, k == ldapUserSurname       ]
-    userTitle'          = fold [ v | (k, v) <- ldapData, k == ldapUserTitle         ]
-    userSex'            = fold [ v | (k, v) <- ldapData, k == ldapSex               ]
-
-    userAuthentication
-      | is _UpsertCampusUserOther plugin
-      = error "PWHash should only work for users that are already known"
-      | otherwise = AuthLDAP
-    userLastAuthentication = now <$ guard (isn't _UpsertCampusUserDummy plugin)
-
-  userIdent <- if
-    | [bs] <- userIdent''
-    , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
-    , hasn't _upsertCampusUserIdent plugin || has (_upsertCampusUserIdent . only userIdent') plugin
-      -> return userIdent'
-    | Just userIdent' <- plugin ^? _upsertCampusUserIdent
-      -> return userIdent'
-    | otherwise
-      -> throwM CampusUserInvalidIdent
-  userEmail <- if
-    | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') userEmail'
-      -> return $ CI.mk userEmail
-    | otherwise
-      -> throwM CampusUserInvalidEmail
-  userDisplayName' <- if
-    | [bs] <- userDisplayName''
-    , Right userDisplayName' <- Text.decodeUtf8' bs
-      -> return userDisplayName'
-    | otherwise
-      -> throwM CampusUserInvalidDisplayName
-  userFirstName <- if
-    | [bs] <- userFirstName'
-    , Right userFirstName <- Text.decodeUtf8' bs
-      -> return userFirstName
-    | otherwise
-      -> throwM CampusUserInvalidGivenName
-  userSurname <- if
-    | [bs] <- userSurname'
-    , Right userSurname <- Text.decodeUtf8' bs
-      -> return userSurname
-    | otherwise
-      -> throwM CampusUserInvalidSurname
-  userTitle <- if
-    | all ByteString.null userTitle'
-      -> return Nothing
-    | [bs] <- userTitle'
-    , Right userTitle <- Text.decodeUtf8' bs
-      -> return $ Just userTitle
-    | otherwise
-      -> throwM CampusUserInvalidTitle
-  userMatrikelnummer <- if
-    | [bs] <- userMatrikelnummer'
-    , Right userMatrikelnummer <- Text.decodeUtf8' bs
-      -> return $ Just userMatrikelnummer
-    | [] <- userMatrikelnummer'
-      -> return Nothing
-    | otherwise
-      -> throwM CampusUserInvalidMatriculation
-  userSex <- if
-    | [bs] <- userSex'
-    , Right userSex'' <- Text.decodeUtf8' bs
-    , Just userSex''' <- readMay userSex''
-    , Just userSex <- userSex''' ^? iso5218
-      -> return $ Just userSex
-    | [] <- userSex'
-      -> return   Nothing
-    | otherwise
-      -> throwM CampusUserInvalidSex
-
-  let
-    newUser = User
-      { userMaxFavourites        = userDefaultMaxFavourites
-      , userMaxFavouriteTerms    = userDefaultMaxFavouriteTerms
-      , userTheme                = userDefaultTheme
-      , userDateTimeFormat       = userDefaultDateTimeFormat
-      , userDateFormat           = userDefaultDateFormat
-      , userTimeFormat           = userDefaultTimeFormat
-      , userDownloadFiles        = userDefaultDownloadFiles
-      , userWarningDays          = userDefaultWarningDays
-      , userShowSex              = userDefaultShowSex
-      , userNotificationSettings = def
-      , userLanguages            = Nothing
-      , userCsvOptions           = def
-      , userTokensIssuedAfter    = Nothing
-      , userCreated              = now
-      , userLastLdapSynchronisation = Just now
-      , userDisplayName          = userDisplayName'
-      , userDisplayEmail         = userEmail
-      , ..
-      }
-    userUpdate =  [ UserMatrikelnummer          =. userMatrikelnummer
-                  -- , UserDisplayName             =. userDisplayName
-                  , UserFirstName               =. userFirstName
-                  , UserSurname                 =. userSurname
-                  , UserTitle                   =. userTitle
-                  , UserEmail                   =. userEmail
-                  , UserSex                     =. userSex
-                  , UserLastLdapSynchronisation =. Just now
-                  ] ++
-                  [ UserLastAuthentication =. Just now | isn't _UpsertCampusUserDummy plugin ]
-
-  user@(Entity userId userRec) <- upsertBy (UniqueAuthentication userIdent) newUser userUpdate
-  unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $
-    update userId [ UserDisplayName =. userDisplayName' ]
-
-  let
-    userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
-    userStudyFeatures' = do
-      (k, v) <- ldapData
-      guard $ k == ldapUserStudyFeatures
-      v' <- v
-      Right str <- return $ Text.decodeUtf8' v'
-      return str
-
-    termNames = nubBy ((==) `on` CI.mk) $ do
-      (k, v) <- ldapData
-      guard $ k == ldapUserFieldName
-      v' <- v
-      Right str <- return $ Text.decodeUtf8' v'
-      return str
-
-    userSubTermsSemesters = forM userSubTermsSemesters' parseSubTermsSemester
-    userSubTermsSemesters' = do
-      (k, v) <- ldapData
-      guard $ k == ldapUserSubTermsSemester
-      v' <- v
-      Right str <- return $ Text.decodeUtf8' v'
-      return str
-
-  fs' <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures
-  sts <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userSubTermsSemesters
-
-  let
-    studyTermCandidates = Set.fromList $ do
-      let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs'
-          subTermsKeys = unStudyTermsKey . fst <$> sts
-
-      (,) <$> sfKeys ++ subTermsKeys <*> termNames
-
-  let
-    assimilateSubTerms :: [(StudyTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudyTermsId, Maybe StudyTermsId)) DB [StudyFeatures]
-    assimilateSubTerms [] xs = return xs
-    assimilateSubTerms ((subterm, subSemester) : subterms) unusedFeats = do
-      standalone <- lift $ get subterm
-      case standalone of
-        _other
-          | (match : matches, unusedFeats') <- partition
-              (\StudyFeatures{..} -> subterm     == studyFeaturesField
-                                  && subSemester == studyFeaturesSemester
-              ) unusedFeats
-            -> do
-              $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” and matching feature “#{tshow match}”|]
-              (:) match <$> assimilateSubTerms subterms (matches ++ unusedFeats')
-          | any ((== subterm) . studyFeaturesField) unusedFeats
-            -> do
-              $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” due to feature of matching field|]
-              assimilateSubTerms subterms unusedFeats
-        Just StudyTerms{..}
-          | Just defDegree <- studyTermsDefaultDegree
-          , Just defType   <- studyTermsDefaultType
-            -> do
-              $logDebugS "Campus" [st|Applying default for standalone study term “#{tshow subterm}”|]
-              (:) (StudyFeatures userId defDegree subterm Nothing defType subSemester now True) <$> assimilateSubTerms subterms unusedFeats
-        Nothing
-          | [] <- unusedFeats -> do
-              $logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|]
-              tell $ Set.singleton (subterm, Nothing)
-              assimilateSubTerms subterms []
-        _other -> do
-          knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] []
-          let matchingFeatures = case knownParents of
-                []      -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats
-                ps      -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> elem studyFeaturesField ps && studyFeaturesSemester == subSemester) unusedFeats
-          when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} ->
-            tell $ Set.singleton (subterm, Just studyFeaturesField)
-          if
-            | not $ null knownParents -> do
-                $logDebugS "Campus" [st|Applying subterm “#{tshow subterm}” to #{tshow matchingFeatures}|]
-                let setSuperField sf = sf
-                      & _studyFeaturesSuperField %~ (<|> Just (sf ^. _studyFeaturesField))
-                      & _studyFeaturesField .~ subterm
-                (++) (map setSuperField matchingFeatures) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures)
-            | otherwise -> do
-                $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}”|]
-                assimilateSubTerms subterms unusedFeats
-  $logDebugS "Campus" [st|Terms for “#{userIdent}”: #{tshow (sts, fs')}|]
-  (fs, studyFieldParentCandidates) <- runWriterT $ assimilateSubTerms sts fs'
-
-  let
-    studyTermCandidateIncidence
-      = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen
-      . UUID.fromByteString
-      . fromStrict
-      . (convert :: Digest (SHAKE128 128) -> ByteString)
-      . runConduitPure
-      $ sourceList ((toStrict . Binary.encode <$> Set.toList studyTermCandidates) ++ (toStrict . Binary.encode <$> Set.toList studyFieldParentCandidates)) .| sinkHash
-
-  candidatesRecorded <- E.selectExists . E.from $ \(candidate `E.FullOuterJoin` parentCandidate `E.FullOuterJoin` standaloneCandidate) -> do
-    E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence
-    E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. parentCandidate E.?. StudySubTermParentCandidateIncidence
-    E.where_ $ candidate E.?. StudyTermNameCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
-         E.||. parentCandidate E.?. StudySubTermParentCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
-         E.||. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
-
-  unless candidatesRecorded $ do
-    let
-      studyTermCandidates' = do
-        (studyTermNameCandidateKey, studyTermNameCandidateName) <- Set.toList studyTermCandidates
-        let studyTermNameCandidateIncidence = studyTermCandidateIncidence
-        return StudyTermNameCandidate{..}
-    insertMany_ studyTermCandidates'
-
-    let
-      studySubTermParentCandidates' = do
-        (StudyTermsKey' studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates
-        let studySubTermParentCandidateIncidence = studyTermCandidateIncidence
-        return StudySubTermParentCandidate{..}
-    insertMany_ studySubTermParentCandidates'
-
-    let
-      studyTermStandaloneCandidates' = do
-        (StudyTermsKey' studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates
-        let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence
-        return StudyTermStandaloneCandidate{..}
-    insertMany_ studyTermStandaloneCandidates'
-
-  E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
-  forM_ fs $ \f@StudyFeatures{..} -> do
-    insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
-    insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing
-    oldFs <- selectKeysList
-      [ StudyFeaturesUser ==. studyFeaturesUser
-       , StudyFeaturesDegree ==. studyFeaturesDegree
-       , StudyFeaturesField ==. studyFeaturesField
-       , StudyFeaturesType ==. studyFeaturesType
-       , StudyFeaturesSemester ==. studyFeaturesSemester
-       ]
-      []
-    case oldFs of
-      [oldF] -> update oldF
-        [ StudyFeaturesUpdated =. now
-        , StudyFeaturesValid =. True
-        , StudyFeaturesField =. studyFeaturesField
-        , StudyFeaturesSuperField =. studyFeaturesSuperField
-        ]
-      _other -> void $ upsert f
-        [ StudyFeaturesUpdated =. now
-        , StudyFeaturesValid =. True
-        , StudyFeaturesSuperField =. studyFeaturesSuperField
-        ]
-  associateUserSchoolsByTerms userId
-
-  let
-    userAssociatedSchools = concat <$> forM userAssociatedSchools' parseLdapSchools
-    userAssociatedSchools' = do
-      (k, v) <- ldapData
-      guard $ k == ldapUserSchoolAssociation
-      v' <- v
-      Right str <- return $ Text.decodeUtf8' v'
-      return str
-
-  ss <- either (throwM . CampusUserInvalidAssociatedSchools . tshow) return userAssociatedSchools
-
-  forM_ ss $ \frag -> void . runMaybeT $ do
-    let
-      exactMatch = MaybeT . getBy $ UniqueOrgUnit frag
-      infixMatch = (hoistMaybe . preview _head) <=< (lift . E.select . E.from) $ \schoolLdap -> do
-        E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit
-             E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool)
-        return schoolLdap
-    Entity _ SchoolLdap{..} <- exactMatch <|> infixMatch
-    ssh <- hoistMaybe schoolLdapSchool
-
-    lift . void $ insertUnique UserSchool
-      { userSchoolUser     = userId
-      , userSchoolSchool   = ssh
-      , userSchoolIsOptOut = False
-      }
-
-  forM_ ss $ void . insertUnique . SchoolLdap Nothing
-
-  return user
-  where
-    insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
-
-associateUserSchoolsByTerms :: UserId -> DB ()
-associateUserSchoolsByTerms uid = do
-  sfs <- selectList [StudyFeaturesUser ==. uid] []
-
-  forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do
-    schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] []
-    forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) ->
-      void $ insertUnique UserSchool
-        { userSchoolUser     = uid
-        , userSchoolSchool   = schoolTermsSchool
-        , userSchoolIsOptOut = False
-        }
-
-updateUserLanguage :: Maybe Lang -> DB (Maybe Lang)
-updateUserLanguage (Just lang) = do
-  unless (lang `elem` appLanguages) $
-    invalidArgs ["Unsupported language"]
-
-  muid <- maybeAuthId
-  for_ muid $ \uid -> do
-    langs <- languages
-    update uid [ UserLanguages =. Just (Languages $ lang : nub (filter ((&&) <$> (`elem` appLanguages) <*> (/= lang)) langs)) ]
-  setRegisteredCookie CookieLang lang
-  return $ Just lang
-updateUserLanguage Nothing = runMaybeT $ do
-  uid <- MaybeT maybeAuthId
-  User{..} <- MaybeT $ get uid
-  setLangs <- toList . selectLanguages appLanguages <$> languages
-  highPrioSetLangs <- toList . selectLanguages appLanguages <$> highPrioRequestedLangs
-  let userLanguages' = toList . selectLanguages appLanguages <$> userLanguages ^? _Just . _Wrapped
-  lang <- case (userLanguages', setLangs, highPrioSetLangs) of
-    (_, _, hpl : _)
-      -> lift $ hpl <$ update uid [ UserLanguages =. Just (Languages highPrioSetLangs) ]
-    (Just (l : _), _, _)
-      -> return l
-    (Nothing, l : _, _)
-      -> lift $ l <$ update uid [ UserLanguages =. Just (Languages setLangs) ]
-    (Just [], l : _, _)
-      -> return l
-    (_, [], _)
-      -> mzero
-  setRegisteredCookie CookieLang lang
-  return lang
-
-
-instance YesodAuth UniWorX where
-    type AuthId UniWorX = UserId
-
-    -- Where to send a user after successful login
-    loginDest _ = NewsR
-    -- Where to send a user after logout
-    logoutDest _ = NewsR
-    -- Override the above two destinations when a Referer: header is present
-    redirectToReferer _ = True
-
-    loginHandler = do
-      toParent <- getRouteToParent
-      liftHandler . defaultLayout $ do
-        plugins <- getsYesod authPlugins
-        $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins)
-
-        setTitleI MsgLoginTitle
-        $(widgetFile "login")
-
-    authenticate creds@Creds{..} = liftHandler . runDB $ do
-      now <- liftIO getCurrentTime
-
-      let
-        uAuth = UniqueAuthentication $ CI.mk credsIdent
-        upsertMode = creds ^? _upsertCampusUserMode
-
-        isDummy = is (_Just . _UpsertCampusUserDummy) upsertMode
-        isOther = is (_Just . _UpsertCampusUserOther) upsertMode
-
-        excRecovery res
-          | isDummy || isOther
-          = do
-              case res of
-                UserError   err -> addMessageI Error   err
-                ServerError err -> addMessage  Error $ toHtml err
-                _other          -> return ()
-              acceptExisting
-          | otherwise
-          = return res
-
-        excHandlers =
-          [ C.Handler $ \case
-              CampusUserNoResult -> do
-                $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
-                excRecovery . UserError $ IdentifierNotFound credsIdent
-              CampusUserAmbiguous -> do
-                $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
-                excRecovery . UserError $ IdentifierNotFound credsIdent
-              err -> do
-                $logErrorS "LDAP" $ tshow err
-                mr <- getMessageRender
-                excRecovery . ServerError $ mr MsgInternalLdapError
-          , C.Handler $ \(cExc :: CampusUserConversionException) -> do
-              $logErrorS "LDAP" $ tshow cExc
-              mr <- getMessageRender
-              excRecovery . ServerError $ mr cExc
-          ]
-
-        acceptExisting = do
-          res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
-          case res of
-            Authenticated uid
-              -> associateUserSchoolsByTerms uid
-            _other
-              -> return ()
-          case res of
-            Authenticated uid
-              | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
-            _other -> return res
-
-      $logDebugS "auth" $ tshow Creds{..}
-      UniWorX{..} <- getYesod
-
-      flip catches excHandlers $ case appLdapPool of
-        Just ldapPool
-          | Just upsertMode' <- upsertMode -> do
-              ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
-              $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
-              Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData
-        _other
-          -> acceptExisting
-
-    authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool } = catMaybes
-      [ flip campusLogin campusUserFailoverMode <$> appLdapPool
-      , Just . hashLogin $ pwHashAlgorithm appAuthPWHash
-      , dummyLogin <$ guard appAuthDummyLogin
-      ]
-
-    authHttpManager = getsYesod appHttpManager
-
-    onLogin = liftHandler $ do
-      mlang <- runDB $ updateUserLanguage Nothing
-      app <- getYesod
-      let mr | Just lang <- mlang = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang
-             | otherwise = renderMessage app []
-      addMessage Success . toHtml $ mr Auth.NowLoggedIn
-
-    onErrorHtml dest msg = do
-      addMessage Error $ toHtml msg
-      redirect dest
-
-    renderAuthMessage _ ls = case lang of
-      ("en" : _) -> Auth.englishMessage
-      _other     -> Auth.germanMessage
-      where lang = Text.splitOn "-" $ selectLanguage' appLanguages ls
-
-campusUserFailoverMode :: FailoverMode
-campusUserFailoverMode = FailoverUnlimited
-
-instance YesodAuthPersist UniWorX where
-  getAuthEntity = liftHandler . runDBRead . get
-
-
-unsafeHandler :: UniWorX -> Handler a -> IO a
-unsafeHandler f h = do
-  logger <- makeLogger f
-  Unsafe.fakeHandlerGetLogger (const logger) f h
-
-
-instance YesodMail UniWorX where
-  defaultFromAddress = getsYesod $ view _appMailFrom
-  mailObjectIdDomain = getsYesod $ view _appMailObjectDomain
-  mailVerp = getsYesod $ view _appMailVerp
-  mailDateTZ = return appTZ
-  mailSmtp act = do
-    pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
-    withResource pool act
-  mailT ctx mail = defMailT ctx $ do
-    void setMailObjectIdRandom
-    setDateCurrent
-    replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail)
-
-    (mRes, smtpData) <- listen mail
-    unless (view _MailSmtpDataSet smtpData)
-      setMailSmtpData
-
-    return mRes
-
-
-instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
-  type MonadCryptoKey m = CryptoIDKey
-  cryptoIDKey f = getsYesod appCryptoIDKey >>= f
-
-instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadSecretBox m where
-  secretBoxKey = getsYesod appSecretBoxKey
-
--- Note: Some functionality previously present in the scaffolding has been
--- moved to documentation in the Wiki. Following are some hopefully helpful
--- links:
---
--- https://github.com/yesodweb/yesod/wiki/Sending-email
--- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
--- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
-
-
-embedRenderMessage ''UniWorX ''ButtonSubmit id
-
-embedRenderMessage ''UniWorX ''CampusUserConversionException id
+import Foundation.Instances as Foundation (ButtonClass(..), unsafeHandler) 
+import Foundation.Authorization as Foundation
+import Foundation.SiteLayout as Foundation
+import Foundation.DB as Foundation
+import Foundation.Navigation as Foundation (evalAccessCorrector)
+import Foundation.Yesod.Middleware as Foundation (updateFavourites)
diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs
new file mode 100644
index 000000000..991224b2f
--- /dev/null
+++ b/src/Foundation/Authorization.hs
@@ -0,0 +1,1475 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
+module Foundation.Authorization
+  ( evalAccess, evalAccessFor, evalAccessWith
+  , evalAccessDB, evalAccessForDB, evalAccessWithDB
+  , hasReadAccessTo, hasWriteAccessTo
+  , wouldHaveReadAccessTo, wouldHaveWriteAccessTo
+  , wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff
+  , AuthContext(..), getAuthContext
+  , isDryRun
+  , maybeBearerToken, requireBearerToken
+  , requireCurrentBearerRestrictions, maybeCurrentBearerRestrictions
+  , BearerAuthSite
+  , routeAuthTags
+  , orAR, andAR, notAR, trueAR, falseAR
+  ) where
+
+import Import.NoFoundation
+
+import Foundation.Type
+import Foundation.Routes
+import Foundation.I18n
+
+import Foundation.DB
+
+import Handler.Utils.ExamOffice.Exam
+import Handler.Utils.ExamOffice.ExternalExam
+import Utils.Course (courseIsVisible)
+  
+import qualified Data.Set as Set
+import qualified Data.Aeson as JSON
+import qualified Data.HashSet as HashSet
+import qualified Data.Map as Map
+import Data.Map ((!?))
+import qualified Data.Text as Text
+import Data.List (findIndex)
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Writer.Class (MonadWriter(..))
+import Control.Monad.Memo.Class (MonadMemo(..), for4)
+
+import Data.Aeson.Lens hiding (_Value, key)
+
+
+type BearerAuthSite site
+  = ( MonadCrypto (HandlerFor site)
+    , CryptoIDKey ~ MonadCryptoKey (HandlerFor site)
+    , MonadCrypto (ReaderT SqlBackend (HandlerFor site))
+    , CryptoIDKey ~ MonadCryptoKey (ReaderT SqlBackend (HandlerFor site))
+    , MonadCrypto (ExceptT AuthResult (HandlerFor site))
+    , CryptoIDKey ~ MonadCryptoKey (ExceptT AuthResult (HandlerFor site))
+    , MonadCrypto (MaybeT (HandlerFor site))
+    , CryptoIDKey ~ MonadCryptoKey (MaybeT (HandlerFor site))
+    , MonadCrypto (ExceptT AuthResult (ReaderT SqlReadBackend (HandlerFor site)))
+    , CryptoIDKey ~ MonadCryptoKey (ExceptT AuthResult (ReaderT SqlReadBackend (HandlerFor site)))
+    , MonadCrypto (ReaderT SqlReadBackend (HandlerFor site))
+    , CryptoIDKey ~ MonadCryptoKey (ReaderT SqlReadBackend (HandlerFor site))
+    , MonadCrypto (MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor site))))
+    , CryptoIDKey ~ MonadCryptoKey (MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor site))))
+    , MonadCrypto (MaybeT (ReaderT SqlReadBackend (HandlerFor site)))
+    , CryptoIDKey ~ MonadCryptoKey (MaybeT (ReaderT SqlReadBackend (HandlerFor site)))
+    , UserId ~ AuthId site, User ~ AuthEntity site
+    , YesodAuthPersist site
+    )
+
+
+-- Access Control
+newtype InvalidAuthTag = InvalidAuthTag Text
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+instance Exception InvalidAuthTag
+
+
+data AccessPredicate
+  = APPure     (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
+  | APHandler  (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult)
+  | APDB       (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult)
+
+class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where
+  evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
+
+instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where
+  evalAccessPred aPred aid r w = liftHandler $ case aPred of
+    (APPure    p) -> runReader (p aid r w) <$> getMsgRenderer
+    (APHandler p) -> p aid r w
+    (APDB      p) -> runDBRead $ p aid r w
+
+instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX) => MonadAP (ReaderT backend m) where
+  evalAccessPred aPred aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of
+    (APPure    p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
+    (APHandler p) -> lift $ p aid r w
+    (APDB      p) -> p aid r w
+
+
+orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
+orAR  _  Authorized _ = Authorized
+orAR  _  _ Authorized = Authorized
+orAR  _  AuthenticationRequired _  = AuthenticationRequired
+orAR  _  _ AuthenticationRequired  = AuthenticationRequired
+orAR  mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y
+-- and
+andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y
+andAR _  reason@(Unauthorized _) _ = reason
+andAR _  _ reason@(Unauthorized _) = reason
+andAR _  Authorized          other = other
+andAR _  AuthenticationRequired  _ = AuthenticationRequired
+
+notAR :: RenderMessage UniWorX msg => MsgRenderer -> msg -> AuthResult -> AuthResult
+notAR _  _   (Unauthorized _)        = Authorized
+notAR _  _    AuthenticationRequired = AuthenticationRequired
+notAR mr msg  Authorized             = Unauthorized . render mr . MsgUnauthorizedNot $ render mr msg
+
+trueAR, falseAR :: MsgRendererS UniWorX -> AuthResult
+trueAR = const Authorized
+falseAR = Unauthorized . ($ MsgUnauthorized) . render
+
+trueAP, _falseAP :: AccessPredicate
+trueAP  = APPure . const . const . const $ trueAR <$> ask
+_falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness
+
+
+data AuthContext = AuthContext
+  { authCtxAuth    :: Maybe (AuthId UniWorX)
+  , authCtxBearer  :: Maybe (BearerToken UniWorX)
+  , authActiveTags :: AuthTagActive
+  } deriving (Generic, Typeable)
+
+deriving instance Eq (AuthId UniWorX) => Eq AuthContext
+deriving instance (Read (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Read AuthContext
+deriving instance (Show (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Show AuthContext
+deriving anyclass instance Hashable (AuthId UniWorX) => Hashable AuthContext
+deriving anyclass instance (Binary (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Binary AuthContext
+
+getAuthContext :: forall m.
+                  ( MonadHandler m, HandlerSite m ~ UniWorX
+                  , BearerAuthSite UniWorX
+                  )
+               => m AuthContext
+getAuthContext = liftHandler $ do
+  authCtx <- AuthContext
+    <$> maybeAuthId
+    <*> runMaybeT (exceptTMaybe askBearerUnsafe)
+    <*> (fromMaybe def <$> lookupSessionJson SessionActiveAuthTags)
+
+  $logDebugS "getAuthContext" $ tshow authCtx
+
+  return authCtx
+
+isDryRun :: forall m.
+            ( MonadHandler m, HandlerSite m ~ UniWorX
+            , BearerAuthSite UniWorX
+            )
+         => m Bool
+isDryRun = $cachedHere . liftHandler $ orM
+  [ hasGlobalPostParam PostDryRun
+  , hasGlobalGetParam GetDryRun
+  , and2M bearerDryRun bearerRequired
+  ]
+  where
+    bearerDryRun = has (_Just . _Object . ix "dry-run") <$> maybeCurrentBearerRestrictions @Value
+    bearerRequired = maybeT (return True) . catchIfMaybeT cPred . liftHandler $ do
+      mAuthId <- maybeAuthId
+      currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
+      isWrite <- isWriteRequest currentRoute
+
+      let noTokenAuth :: AuthDNF -> AuthDNF
+          noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
+
+      dnf <- either throwM return $ routeAuthTags currentRoute
+      guardAuthResult <=< fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) mAuthId currentRoute isWrite
+
+      return False
+
+    cPred err = any ($ err)
+      [ is $ _HCError . _PermissionDenied
+      , is $ _HCError . _NotAuthenticated
+      ]
+
+
+askBearerUnsafe :: forall m.
+                  ( MonadHandler m, HandlerSite m ~ UniWorX
+                  , BearerAuthSite UniWorX
+                  )
+               => ExceptT AuthResult m (BearerToken UniWorX)
+-- | This performs /no/ meaningful validation of the `BearerToken`
+--
+-- Use `requireBearerToken` or `maybeBearerToken` instead
+askBearerUnsafe = ExceptT . $cachedHere . liftHandler . runExceptT $ do
+  bearer <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askBearer
+  catch (decodeBearer bearer) $ \case
+    BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
+    BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
+    other -> do
+      $logWarnS "AuthToken" $ tshow other
+      throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid
+
+validateBearer :: BearerAuthSite UniWorX
+               => Maybe (AuthId UniWorX)
+               -> Route UniWorX
+               -> Bool -- ^ @isWrite@
+               -> BearerToken UniWorX
+               -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult
+validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateBearer' mAuthId' route' isWrite' token'
+  where
+    validateBearer' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult (ReaderT SqlReadBackend (HandlerFor UniWorX)) AuthResult
+    validateBearer' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
+      guardMExceptT (maybe True (HashSet.member route) bearerRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)
+
+      bearerAuthority' <- flip foldMapM bearerAuthority $ \case
+        Left tVal
+          | JSON.Success groupName <- JSON.fromJSON tVal -> maybeT (throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . hoist lift $ do
+              Entity _ UserGroupMember{..} <- MaybeT . getBy $ UniquePrimaryUserGroupMember groupName Active
+              return $ Set.singleton userGroupMemberUser
+          | otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue
+        Right uid -> return $ Set.singleton uid
+
+      let
+        -- Prevent infinite loops
+        noTokenAuth :: AuthDNF -> AuthDNF
+        noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
+
+      guardMExceptT (not $ Set.null bearerAuthority') $ unauthorizedI MsgUnauthorizedTokenInvalidNoAuthority
+
+      forM_ bearerAuthority' $ \uid -> do
+        User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get uid
+        guardMExceptT (Just bearerIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
+
+        authorityVal <- do
+          dnf <- either throwM return $ routeAuthTags route
+          fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just uid) route isWrite
+        guardExceptT (is _Authorized authorityVal) authorityVal
+
+      whenIsJust bearerAddAuth $ \addDNF -> do
+        $logDebugS "validateToken" $ tshow addDNF
+        additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth addDNF) mAuthId route isWrite
+        guardExceptT (is _Authorized additionalVal) additionalVal
+
+      return Authorized
+
+maybeBearerToken :: ( MonadHandler m, HandlerSite m ~ UniWorX
+                    , BearerAuthSite UniWorX
+                    ) => m (Maybe (BearerToken UniWorX))
+maybeBearerToken = liftHandler . runMaybeT $ catchIfMaybeT cPred requireBearerToken
+  where
+    cPred err = any ($ err)
+      [ is $ _HCError . _PermissionDenied
+      , is $ _HCError . _NotAuthenticated
+      ]
+
+requireBearerToken :: ( MonadHandler m, HandlerSite m ~ UniWorX
+                      , BearerAuthSite UniWorX
+                      )
+                   => m (BearerToken UniWorX)
+requireBearerToken = liftHandler $ do
+  bearer <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askBearerUnsafe
+  mAuthId <- maybeAuthId
+  currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
+  isWrite <- isWriteRequest currentRoute
+  guardAuthResult <=< runDBRead $ validateBearer mAuthId currentRoute isWrite bearer
+  return bearer
+
+requireCurrentBearerRestrictions :: forall a m.
+                                    ( MonadHandler m, HandlerSite m ~ UniWorX
+                                    , FromJSON a, ToJSON a
+                                    , BearerAuthSite UniWorX
+                                    )
+                                 => m (Maybe a)
+requireCurrentBearerRestrictions = liftHandler . runMaybeT $ do
+  bearer <- requireBearerToken
+  route <- MaybeT getCurrentRoute
+  hoistMaybe $ bearer ^? _bearerRestrictionIx route
+
+maybeCurrentBearerRestrictions :: forall a m.
+                                  ( MonadHandler m, HandlerSite m ~ UniWorX
+                                  , FromJSON a, ToJSON a
+                                  , BearerAuthSite UniWorX
+                                  )
+                               => m (Maybe a)
+maybeCurrentBearerRestrictions = liftHandler . runMaybeT $ do
+  bearer <- MaybeT maybeBearerToken
+  route <- MaybeT getCurrentRoute
+  hoistMaybe $ bearer ^? _bearerRestrictionIx route
+
+tagAccessPredicate :: BearerAuthSite UniWorX
+                   => AuthTag -> AccessPredicate
+tagAccessPredicate AuthFree = trueAP
+tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
+  -- Courses: access only to school admins
+  CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do
+      E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserFunctionSchool
+      E.where_  $ userAdmin E.^. UserFunctionUser E.==. E.val authId
+            E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
+            E.&&. course E.^. CourseTerm      E.==. E.val tid
+            E.&&. course E.^. CourseSchool    E.==. E.val ssh
+            E.&&. course E.^. CourseShorthand E.==. E.val csh
+    guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
+    return Authorized
+  -- Allocations: access only to school admins
+  AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do
+      E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserFunctionSchool
+      E.where_  $ userAdmin E.^. UserFunctionUser E.==. E.val authId
+            E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
+            E.&&. allocation E.^. AllocationTerm      E.==. E.val tid
+            E.&&. allocation E.^. AllocationSchool    E.==. E.val ssh
+            E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
+    guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
+    return Authorized
+  -- Schools: access only to school admins
+  SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin]
+    guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
+    return Authorized
+  -- other routes: access to any admin is granted here
+  _other -> $cachedHereBinary mAuthId . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] []
+    guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
+    return Authorized
+tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of
+  CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    hasUsers <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
+      E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
+      E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
+
+      E.where_ $ course E.^. CourseTerm E.==. E.val tid
+           E.&&. course E.^. CourseSchool E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+           E.&&. exam E.^. ExamName E.==. E.val examn
+
+      E.where_ $ examOfficeExamResultAuth (E.val authId) examResult
+    guardMExceptT hasUsers (unauthorizedI MsgUnauthorizedExamExamOffice)
+    return Authorized
+  EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    hasUsers <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do
+      E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam
+
+      E.where_ $ eexam E.^. ExternalExamTerm E.==. E.val tid
+           E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh
+           E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen
+           E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn
+
+      E.where_ $ examOfficeExternalExamResultAuth (E.val authId) eexamResult
+    guardMExceptT hasUsers $ unauthorizedI MsgUnauthorizedExternalExamExamOffice
+    return Authorized
+  CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isExamOffice <- lift . existsBy $ UniqueUserFunction authId ssh SchoolExamOffice
+    guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedExamExamOffice
+    return Authorized
+  _other -> $cachedHereBinary mAuthId . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice]
+    guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice)
+    return Authorized
+tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of
+  ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation
+    guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
+    return Authorized
+  CourseR _ ssh _ _ -> $cachedHereBinary(mAuthId, ssh) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation
+    guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
+    return Authorized
+  _other -> $cachedHereBinary mAuthId . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation]
+    guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
+    return Authorized
+tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route of
+  AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation
+    guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
+    return Authorized
+  CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation
+    guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
+    return Authorized
+  _other -> $cachedHereBinary mAuthId . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation]
+    guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
+    return Authorized
+tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $
+  lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe
+tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
+  AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
+    myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
+    uid <- decrypt cID
+    otherSchoolsFunctions <- lift . $cachedHereBinary uid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid] []
+    mySchools <- lift . $cachedHereBinary myUid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. myUid, UserFunctionFunction ==. SchoolAdmin] []
+    guardMExceptT (otherSchoolsFunctions `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthNoEscalation r
+tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do
+  $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
+  addMessageI Error MsgDeprecatedRoute
+  allow <- getsYesod $ view _appAllowDeprecated
+  return $ bool (Unauthorized "Deprecated Route") Authorized allow
+tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
+  $logWarnS "AccessControl" ("route in development: " <> tshow r)
+#ifdef DEVELOPMENT
+  return Authorized
+#else
+  return $ Unauthorized "Route under development"
+#endif
+tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
+  CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
+     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+     isLecturer <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` lecturer) -> do
+       E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
+       E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
+            E.&&. course E.^. CourseTerm      E.==. E.val tid
+            E.&&. course E.^. CourseSchool    E.==. E.val ssh
+            E.&&. course E.^. CourseShorthand E.==. E.val csh
+     guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer)
+     return Authorized
+  AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
+      E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
+      E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
+      E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
+      E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
+           E.&&. allocation E.^. AllocationTerm      E.==. E.val tid
+           E.&&. allocation E.^. AllocationSchool    E.==. E.val ssh
+           E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
+    guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedAllocationLecturer
+    return Authorized
+  EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isLecturer <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` staff) -> do
+      E.on $ eexam E.^. ExternalExamId E.==. staff E.^. ExternalExamStaffExam
+      E.where_ $ staff E.^. ExternalExamStaffUser E.==. E.val authId
+           E.&&. eexam E.^. ExternalExamTerm E.==. E.val tid
+           E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh
+           E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen
+           E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn
+    guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedExternalExamLecturer
+    return Authorized
+  -- lecturer for any school will do
+  _ -> $cachedHereBinary mAuthId . exceptT return return $ do
+     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+     void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] []
+     return Authorized
+tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do
+  authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+  resList <- $cachedHereBinary mAuthId . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
+    E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
+    E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
+    E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
+    return (course E.^. CourseId, sheet E.^. SheetId)
+  let
+    resMap :: Map CourseId (Set SheetId)
+    resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ]
+  case route of
+    CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
+      sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+      Submission{..} <- MaybeT . lift $ get sid
+      guard $ Just authId == submissionRatingBy
+      return Authorized
+    CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
+      Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
+      Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
+      guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
+      return Authorized
+    CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
+      Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
+      guard $ cid `Set.member` Map.keysSet resMap
+      return Authorized
+    _ -> do
+      guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
+      return Authorized
+tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of
+  CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
+      E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId
+      E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
+      E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId
+        E.&&. course E.^. CourseTerm      E.==. E.val tid
+        E.&&. course E.^. CourseSchool    E.==. E.val ssh
+        E.&&. course E.^. CourseShorthand E.==. E.val csh
+        E.&&. exam   E.^. ExamName        E.==. E.val examn
+    guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector
+    return Authorized
+  CourseR tid ssh csh _ -> $cachedHereBinary (tid, ssh, csh) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
+      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+      E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam
+      E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId
+        E.&&. course E.^. CourseTerm      E.==. E.val tid
+        E.&&. course E.^. CourseSchool    E.==. E.val ssh
+        E.&&. course E.^. CourseShorthand E.==. E.val csh
+    guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthExamCorrector r
+tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do
+  authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+  resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
+    E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
+    E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId
+    E.where_ $ tutor E.^. TutorUser E.==. E.val authId
+    return (course E.^. CourseId, tutorial E.^. TutorialId)
+  let
+    resMap :: Map CourseId (Set TutorialId)
+    resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ]
+  case route of
+    CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do
+      Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
+      Entity tutid _ <- $cachedHereBinary (cid, tutn) . MaybeT . lift . getBy $ UniqueTutorial cid tutn
+      guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid)
+      return Authorized
+    CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do
+      Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
+      guard $ cid `Set.member` Map.keysSet resMap
+      return Authorized
+    _ -> do
+      guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor)
+      return Authorized
+tagAccessPredicate AuthTutorControl = APDB $ \_ route _ -> case route of
+  CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do
+    Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
+    Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
+    guard tutorialTutorControlled
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthTutorControl r
+tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route of
+  CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do
+    course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn
+    smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+    groups <- $cachedHereBinary cID . lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionUser) -> do
+      E.on $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. submissionUser E.^. SubmissionUserUser
+      E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smId
+      return $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
+    unless (Set.null groups || isn't _RegisteredGroups sheetGrouping) $ do
+      uid <- hoistMaybe mAuthId
+      guardM . lift $ exists [SubmissionGroupUserUser ==. uid, SubmissionGroupUserSubmissionGroup <-. Set.toList groups]
+    return Authorized
+  CSheetR tid ssh csh sheetn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetSubmissionGroup) $ do
+    course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    Entity _ Sheet{..} <- $cachedHereBinary (course, sheetn) . MaybeT . getBy $ CourseSheet course sheetn
+    when (is _RegisteredGroups sheetGrouping) $ do
+      uid <- hoistMaybe mAuthId
+      guardM . lift . E.selectExists . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
+        E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
+        E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val course
+             E.&&. submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
+
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthSubmissionGroup r
+tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
+  CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
+    course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
+    cTime <- liftIO getCurrentTime
+    registration <- case mAuthId of
+      Just uid -> $cachedHereBinary (eId, uid) . lift . getBy $ UniqueExamRegistration eId uid
+      Nothing  -> return Nothing
+
+    let visible = NTop examVisibleFrom <= NTop (Just cTime)
+
+    case subRoute of
+      EShowR     -> guard visible
+      EUsersR    -> guard $ NTop examStart <= NTop (Just cTime)
+                         && NTop (Just cTime) <= NTop examFinished
+      ERegisterR
+        | is _Nothing registration
+          -> guard $ visible
+                  && NTop examRegisterFrom <= NTop (Just cTime)
+                  && NTop (Just cTime) <= NTop examRegisterTo
+        | otherwise
+          -> guard $ visible
+                  && NTop (Just cTime) <= NTop examDeregisterUntil
+      ERegisterOccR occn -> do
+        occId <- hoistMaybe <=< $cachedHereBinary (eId, occn) . lift . getKeyBy $ UniqueExamOccurrence eId occn
+        if
+          | (registration >>= examRegistrationOccurrence . entityVal) == Just occId
+            -> guard $ visible
+                    && NTop (Just cTime) <= NTop examDeregisterUntil
+          | otherwise
+            -> guard $ visible
+                    && NTop examRegisterFrom <= NTop (Just cTime)
+                    && NTop (Just cTime) <= NTop examRegisterTo
+      ECorrectR -> guard $ NTop (Just cTime) >= NTop examStart
+                        && NTop (Just cTime) <= NTop examFinished
+      _          -> return ()
+
+    return Authorized
+
+  CTutorialR tid ssh csh tutn TRegisterR -> maybeT (unauthorizedI MsgUnauthorizedTutorialTime) $ do
+    now <- liftIO getCurrentTime
+    course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    Entity tutId Tutorial{..} <- $cachedHereBinary (course, tutn) . MaybeT . getBy $ UniqueTutorial course tutn
+    registered <- case mAuthId of
+      Just uid -> $cachedHereBinary (tutId, uid) . lift . existsBy $ UniqueTutorialParticipant tutId uid
+      Nothing  -> return False
+
+    if
+      | not registered
+      , maybe False (now >=) tutorialRegisterFrom
+      , maybe True  (now <=) tutorialRegisterTo
+        -> return Authorized
+      | registered
+      , maybe True  (now <=) tutorialDeregisterUntil
+        -> return Authorized
+      | otherwise
+        -> mzero
+
+  CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
+    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    Entity _sid Sheet{..} <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
+    cTime <- liftIO getCurrentTime
+    let
+      visible = NTop sheetVisibleFrom <= NTop (Just cTime)
+      active  = NTop sheetActiveFrom <= NTop (Just cTime) && NTop (Just cTime) <= NTop sheetActiveTo
+      marking = NTop (Just cTime) > NTop sheetActiveTo
+
+    guard visible
+
+    case subRoute of
+      -- Single Files
+      SFileR                SheetExercise _ -> guard $ NTop sheetActiveFrom <= NTop (Just cTime)
+      SFileR                SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
+      SFileR                SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
+      SFileR                _             _ -> mzero
+      -- Archives of SheetFileType
+      SZipR                 SheetExercise   -> guard $ NTop sheetActiveFrom <= NTop (Just cTime)
+      SZipR                 SheetHint       -> guard $ maybe False (<= cTime) sheetHintFrom
+      SZipR                 SheetSolution   -> guard $ maybe False (<= cTime) sheetSolutionFrom
+      SZipR                 _               -> mzero
+      -- Submissions
+      SubmissionNewR           -> guard   active
+      SAssignR                 -> guard   marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change; this is assumed in Corrections.assignHandler
+      SubmissionR _ SubAssignR -> guard   marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
+      SubmissionR _ _          -> guard   active
+      _                        -> return ()
+
+    return Authorized
+
+  CourseR tid ssh csh (MaterialR mnm _) -> maybeT (unauthorizedI MsgUnauthorizedMaterialTime) $ do
+    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    Entity _mid Material{materialVisibleFrom} <- $cachedHereBinary (cid, mnm) . MaybeT . getBy $ UniqueMaterial cid mnm
+    cTime <- liftIO getCurrentTime
+    let visible = NTop materialVisibleFrom <= NTop (Just cTime)
+    guard visible
+    return Authorized
+
+  CourseR tid ssh csh CRegisterR -> do
+    now <- liftIO getCurrentTime
+    mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh
+    registered <- case (mbc,mAuthId) of
+      (Just (Entity cid _), Just uid) -> $cachedHereBinary (uid, cid) $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive]
+      _ -> return False
+    case mbc of
+      (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo}))
+        | not registered
+        , maybe False (now >=) courseRegisterFrom -- Nothing => no registration allowed
+        , maybe True  (now <=) courseRegisterTo      -> return Authorized
+      (Just (Entity cid Course{courseDeregisterUntil}))
+        | registered
+          -> maybeT (unauthorizedI MsgUnauthorizedCourseRegistrationTime) $ do
+            guard $ maybe True (now <=) courseDeregisterUntil
+            forM_ mAuthId $ \uid -> do
+              exams <- lift . E.select . E.from $ \exam -> do
+                E.where_ . E.exists . E.from $ \examRegistration ->
+                  E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
+                       E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
+                E.where_ $ exam E.^. ExamCourse E.==. E.val cid
+                return $ exam E.^. ExamDeregisterUntil
+              forM_ exams $ \(E.Value deregUntil) ->
+                guard $ NTop (Just now) <= NTop deregUntil
+
+              tutorials <- lift . E.select . E.from $ \tutorial -> do
+                E.where_ . E.exists . E.from $ \tutorialParticipant ->
+                  E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
+                       E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid
+                E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
+                return $ tutorial E.^. TutorialDeregisterUntil
+              forM_ tutorials $ \(E.Value deregUntil) ->
+                guard $ NTop (Just now) <= NTop deregUntil
+            return Authorized
+      _other -> unauthorizedI MsgUnauthorizedCourseRegistrationTime
+  
+  CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
+    Entity course Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
+    allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
+    allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation
+
+    case allocation of
+      Nothing -> do
+        cTime <- liftIO getCurrentTime
+        guard $ maybe False (cTime >=) courseRegisterFrom
+        guard $ maybe True  (cTime <=) courseRegisterTo
+      Just Allocation{..} -> do
+        cTime <- liftIO getCurrentTime
+        guard $ NTop allocationRegisterFrom <= NTop (Just cTime)
+        guard $ NTop (Just cTime) <= NTop allocationRegisterTo
+
+    return Authorized
+
+  AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
+    -- Checks `registerFrom` and `registerTo`, override as further routes become available
+    now <- liftIO getCurrentTime
+    Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash
+    guard $ NTop allocationRegisterFrom <= NTop (Just now)
+    guard $ NTop (Just now) <= NTop allocationRegisterTo
+    return Authorized
+
+  MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
+    smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+    SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
+    cTime <- NTop . Just <$> liftIO getCurrentTime
+    guard $ NTop systemMessageFrom <= cTime
+         && NTop systemMessageTo   >= cTime
+    return Authorized
+
+  MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
+    smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+    SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
+    cTime <- NTop . Just <$> liftIO getCurrentTime
+    guard $ NTop systemMessageFrom <= cTime
+         && NTop systemMessageTo   >= cTime
+    return Authorized
+
+  CNewsR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsTime) $ do
+    nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+    CourseNews{courseNewsVisibleFrom} <- $cachedHereBinary nId . MaybeT $ get nId
+    cTime <- NTop . Just <$> liftIO getCurrentTime
+    guard $ NTop courseNewsVisibleFrom <= cTime
+    return Authorized
+
+  r -> $unsupportedAuthPredicate AuthTime r
+tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of
+  CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
+    course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
+    allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation
+
+    case allocation of
+      Nothing -> return ()
+      Just Allocation{..} -> do
+        cTime <- liftIO getCurrentTime
+        guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime)
+        when isWrite $
+          guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo
+
+    return Authorized
+
+  AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
+    -- Checks `registerFrom` and `registerTo`, override as further routes become available
+    now <- liftIO getCurrentTime
+    Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash
+    guard $ NTop allocationStaffAllocationFrom <= NTop (Just now)
+    guard $ NTop (Just now) <= NTop allocationStaffAllocationTo
+    return Authorized
+
+  r -> $unsupportedAuthPredicate AuthStaffTime r
+tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
+  CourseR tid ssh csh CRegisterR -> do
+    now <- liftIO getCurrentTime
+    mba <- mbAllocation tid ssh csh
+    case mba of
+      Nothing -> return Authorized
+      Just (cid, Allocation{..}) -> do
+        registered <- case mAuthId of
+          Just uid -> $cachedHereBinary (uid, cid) . existsBy $ UniqueParticipant uid cid
+          _        -> return False
+        if
+          | not registered
+          , NTop allocationRegisterByCourse >= NTop (Just now)
+            -> unauthorizedI MsgUnauthorizedAllocatedCourseRegister
+          | registered
+          , NTop (Just now) >= NTop allocationOverrideDeregister
+            -> unauthorizedI MsgUnauthorizedAllocatedCourseDeregister
+          | otherwise
+            -> return Authorized
+
+  CourseR tid ssh csh CAddUserR -> do
+    now <- liftIO getCurrentTime
+    mba <- mbAllocation tid ssh csh
+    case mba of
+      Just (_, Allocation{..})
+        |    NTop allocationRegisterByStaffTo <= NTop (Just now)
+          || NTop allocationRegisterByStaffFrom >= NTop (Just now)
+          -> unauthorizedI MsgUnauthorizedAllocatedCourseRegister
+      _other -> return Authorized
+
+  CourseR tid ssh csh CDeleteR -> do
+    now <- liftIO getCurrentTime
+    mba <- mbAllocation tid ssh csh
+    case mba of
+      Just (_, Allocation{..})
+        |    NTop allocationRegisterByStaffTo <= NTop (Just now)
+          || NTop allocationRegisterByStaffFrom >= NTop (Just now)
+          -> unauthorizedI MsgUnauthorizedAllocatedCourseDelete
+      _other -> return Authorized
+
+  r -> $unsupportedAuthPredicate AuthAllocationTime r
+  where
+    mbAllocation tid ssh csh = $cachedHereBinary (tid, ssh, csh) . runMaybeT $ do
+      cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+      Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid
+      (cid,) <$> MaybeT (get allocationCourseAllocation)
+tagAccessPredicate AuthCourseTime = APDB $ \_mAuthId route _ -> case route of
+  CourseR tid ssh csh _ -> exceptT return return $ do
+    now <- liftIO getCurrentTime
+    courseVisible <- $cachedHereBinary (tid, ssh, csh) . lift . E.selectExists . E.from $ \course -> do
+      E.where_ $ course E.^. CourseTerm      E.==. E.val tid
+           E.&&. course E.^. CourseSchool    E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+           E.&&. courseIsVisible now course Nothing
+    guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime)
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthCourseTime r
+tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of
+  CourseR tid ssh csh _ -> exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
+      E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
+      E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
+           E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
+           E.&&. course E.^. CourseTerm      E.==. E.val tid
+           E.&&. course E.^. CourseSchool    E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+    guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthCourseRegistered r
+tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of
+  CTutorialR tid ssh csh tutn _ -> exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isRegistered <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
+      E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
+      E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
+      E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId
+           E.&&. course E.^. CourseTerm      E.==. E.val tid
+           E.&&. course E.^. CourseSchool    E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+           E.&&. tutorial E.^. TutorialName  E.==. E.val tutn
+    guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
+    return Authorized
+  CourseR tid ssh csh _ -> exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
+      E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
+      E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
+      E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId
+           E.&&. course E.^. CourseTerm      E.==. E.val tid
+           E.&&. course E.^. CourseSchool    E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+    guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthTutorialRegistered r
+tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ route _ -> case route of
+  CExamR tid ssh csh examn _ -> exceptT return return $ do
+    isOccurrenceRegistration <- $cachedHereBinary (tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam) -> do
+      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+      E.where_ $ course E.^. CourseTerm       E.==. E.val tid
+           E.&&. course E.^. CourseSchool     E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand  E.==. E.val csh
+           E.&&. exam E.^. ExamName           E.==. E.val examn
+           E.&&. exam E.^. ExamOccurrenceRule E.==. E.val ExamRoomFifo
+    guardMExceptT isOccurrenceRegistration (unauthorizedI MsgUnauthorizedExamOccurrenceRegistration)
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistration r
+tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \mAuthId route _ -> case route of
+  CExamR tid ssh csh examn (ERegisterOccR occn) -> exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn, occn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration `E.InnerJoin` examOccurrence) -> do
+      E.on $ E.just (examOccurrence E.^. ExamOccurrenceId) E.==. examRegistration E.^. ExamRegistrationOccurrence
+      E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
+      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+      E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
+           E.&&. examOccurrence E.^. ExamOccurrenceName E.==. E.val occn
+           E.&&. course E.^. CourseTerm      E.==. E.val tid
+           E.&&. course E.^. CourseSchool    E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+           E.&&. exam E.^. ExamName          E.==. E.val examn
+    guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
+    return Authorized
+  CExamR tid ssh csh examn _ -> exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
+      E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
+      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+      E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
+           E.&&. course E.^. CourseTerm      E.==. E.val tid
+           E.&&. course E.^. CourseSchool    E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+           E.&&. exam E.^. ExamName          E.==. E.val examn
+           E.&&. E.not_ (E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence)
+    guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
+    return Authorized
+  CourseR tid ssh csh _ -> exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
+      E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
+      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+      E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
+           E.&&. course E.^. CourseTerm      E.==. E.val tid
+           E.&&. course E.^. CourseSchool    E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+           E.&&. E.not_ (E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence)
+    guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistered r
+tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of
+  CExamR tid ssh csh examn _ -> exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
+      E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
+      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+      E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
+           E.&&. course E.^. CourseTerm      E.==. E.val tid
+           E.&&. course E.^. CourseSchool    E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+           E.&&. exam E.^. ExamName          E.==. E.val examn
+    guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredExam
+    return Authorized
+  CSheetR tid ssh csh shn _ -> exceptT return return $ do
+    requiredExam' <- $cachedHereBinary (tid, ssh, csh, shn) . lift . E.selectMaybe . E.from $ \(course `E.InnerJoin` sheet) -> do
+      E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
+      E.where_ $ course E.^. CourseTerm      E.==. E.val tid
+           E.&&. course E.^. CourseSchool    E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+           E.&&. sheet  E.^. SheetName       E.==. E.val shn
+      return $ sheet E.^. SheetRequireExamRegistration
+    requiredExam <- maybeMExceptT (unauthorizedI MsgUnauthorizedRegisteredExam) . return $ E.unValue <$> requiredExam'
+    whenIsJust requiredExam $ \eId -> do
+      authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+      isRegistered <- $cachedHereBinary (authId, eId) . lift . E.selectExists . E.from $ \examRegistration ->
+        E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId
+             E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val authId
+      guardMExceptT isRegistered $ unauthorizedI MsgUnauthorizedRegisteredExam
+    return Authorized
+  CourseR tid ssh csh _ -> exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
+      E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
+      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+      E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
+           E.&&. course E.^. CourseTerm      E.==. E.val tid
+           E.&&. course E.^. CourseSchool    E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+    guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredAnyExam
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthExamRegistered r
+tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of
+  CExamR tid ssh csh examn _ -> exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    hasResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
+      E.on $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam
+      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+      E.where_ $ examResult E.^. ExamResultUser E.==. E.val authId
+           E.&&. course E.^. CourseTerm      E.==. E.val tid
+           E.&&. course E.^. CourseSchool    E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+           E.&&. exam E.^. ExamName  E.==. E.val examn
+    hasPartResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart `E.InnerJoin` examPartResult) -> do
+      E.on $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId
+      E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam
+      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+      E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val authId
+           E.&&. course E.^. CourseTerm      E.==. E.val tid
+           E.&&. course E.^. CourseSchool    E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+           E.&&. exam E.^. ExamName  E.==. E.val examn
+    guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult)
+    return Authorized
+  EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    hasResult <- $cachedHereBinary (authId, tid, ssh, coursen, examn) . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do
+      E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam
+      E.where_ $ eexamResult E.^. ExternalExamResultUser E.==. E.val authId
+           E.&&. eexam E.^. ExternalExamTerm E.==. E.val tid
+           E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh
+           E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen
+           E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn
+    guardMExceptT hasResult $ unauthorizedI MsgUnauthorizedExternalExamResult
+    return Authorized
+  CourseR tid ssh csh _ -> exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    hasResult <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
+      E.on $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam
+      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+      E.where_ $ examResult E.^. ExamResultUser E.==. E.val authId
+           E.&&. course E.^. CourseTerm      E.==. E.val tid
+           E.&&. course E.^. CourseSchool    E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+    hasPartResult <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart `E.InnerJoin` examPartResult) -> do
+      E.on $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId
+      E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam
+      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+      E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val authId
+           E.&&. course E.^. CourseTerm      E.==. E.val tid
+           E.&&. course E.^. CourseSchool    E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+    guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult)
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthExamRegistered r
+tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case route of
+  AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegistered) $ do
+    uid <- hoistMaybe mAuthId
+    aId <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getKeyBy $ TermSchoolAllocationShort tid ssh ash
+    void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthAllocationRegistered r
+tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
+  CNewsR tid ssh csh cID _ -> maybeT (unauthorizedI MsgUnauthorizedParticipantSelf) $ do
+    nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+    CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId
+    if | courseNewsParticipantsOnly -> do
+           uid <- hoistMaybe mAuthId
+           exceptT return (const mzero) . hoist lift $ isCourseParticipant tid ssh csh uid True
+       | otherwise
+           -> return Authorized
+
+  CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
+    participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID
+    isCourseParticipant tid ssh csh participant False
+    unauthorizedI MsgUnauthorizedParticipant
+
+  r -> $unsupportedAuthPredicate AuthParticipant r
+
+  where
+    isCourseParticipant tid ssh csh participant onlyActive = do
+      let
+        authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult (ReaderT SqlReadBackend (HandlerFor UniWorX)) ()
+        authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from
+      -- participant is currently registered
+      mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
+        E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
+        E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant
+             E.&&. course E.^. CourseTerm      E.==. E.val tid
+             E.&&. course E.^. CourseSchool    E.==. E.val ssh
+             E.&&. course E.^. CourseShorthand E.==. E.val csh
+        when onlyActive $
+          E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
+      -- participant has at least one submission
+      unless onlyActive $
+        mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
+          E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
+          E.on $ sheet  E.^. SheetId   E.==. submission E.^. SubmissionSheet
+          E.on $ course E.^. CourseId  E.==. sheet E.^. SheetCourse
+          E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val participant
+               E.&&. course E.^. CourseTerm      E.==. E.val tid
+               E.&&. course E.^. CourseSchool    E.==. E.val ssh
+               E.&&. course E.^. CourseShorthand E.==. E.val csh
+      -- participant is member of a submissionGroup
+      unless onlyActive $
+        mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do
+          E.on $ submissionGroup E.^. SubmissionGroupId  E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
+          E.on $ course E.^. CourseId  E.==. submissionGroup E.^. SubmissionGroupCourse
+          E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant
+               E.&&. course E.^. CourseTerm      E.==. E.val tid
+               E.&&. course E.^. CourseSchool    E.==. E.val ssh
+               E.&&. course E.^. CourseShorthand E.==. E.val csh
+      -- participant is a sheet corrector
+      mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
+        E.on $ sheet  E.^. SheetId   E.==. sheetCorrector E.^. SheetCorrectorSheet
+        E.on $ course E.^. CourseId  E.==. sheet E.^. SheetCourse
+        E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant
+             E.&&. course E.^. CourseTerm      E.==. E.val tid
+             E.&&. course E.^. CourseSchool    E.==. E.val ssh
+             E.&&. course E.^. CourseShorthand E.==. E.val csh
+      -- participant is a tutorial user
+      unless onlyActive $
+        mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do
+          E.on $ tutorial  E.^. TutorialId   E.==. tutorialUser E.^. TutorialParticipantTutorial
+          E.on $ course E.^. CourseId  E.==. tutorial E.^. TutorialCourse
+          E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant
+               E.&&. course E.^. CourseTerm      E.==. E.val tid
+               E.&&. course E.^. CourseSchool    E.==. E.val ssh
+               E.&&. course E.^. CourseShorthand E.==. E.val csh
+      -- participant is tutor for this course
+      mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
+        E.on $ tutorial  E.^. TutorialId   E.==. tutor E.^. TutorTutorial
+        E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
+        E.where_ $ tutor E.^. TutorUser E.==. E.val participant
+             E.&&. course E.^. CourseTerm      E.==. E.val tid
+             E.&&. course E.^. CourseSchool    E.==. E.val ssh
+             E.&&. course E.^. CourseShorthand E.==. E.val csh
+      -- participant is exam corrector for this course
+      mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
+        E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam
+        E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+        E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val participant
+             E.&&. course E.^. CourseTerm      E.==. E.val tid
+             E.&&. course E.^. CourseSchool    E.==. E.val ssh
+             E.&&. course E.^. CourseShorthand E.==. E.val csh
+      -- participant is lecturer for this course
+      mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do
+        E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
+        E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant
+             E.&&. course E.^. CourseTerm      E.==. E.val tid
+             E.&&. course E.^. CourseSchool    E.==. E.val ssh
+             E.&&. course E.^. CourseShorthand E.==. E.val csh
+      -- participant has an exam result for this course
+      unless onlyActive $
+        mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
+          E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
+          E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+          E.where_ $ examResult E.^. ExamResultUser E.==. E.val participant
+               E.&&. course E.^. CourseTerm      E.==. E.val tid
+               E.&&. course E.^. CourseSchool    E.==. E.val ssh
+               E.&&. course E.^. CourseShorthand E.==. E.val csh
+      -- participant is registered for an exam for this course
+      unless onlyActive $
+        mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
+          E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
+          E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+          E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val participant
+               E.&&. course E.^. CourseTerm      E.==. E.val tid
+               E.&&. course E.^. CourseSchool    E.==. E.val ssh
+               E.&&. course E.^. CourseShorthand E.==. E.val csh
+tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of
+  CourseR tid ssh csh (CUserR cID) -> maybeT (unauthorizedI MsgUnauthorizedApplicant) $ do
+    uid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+    isApplicant <- isCourseApplicant tid ssh csh uid
+    guard isApplicant
+    return Authorized
+
+  CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedApplicantSelf) $ do
+    uid <- hoistMaybe mAuthId
+    isApplicant <- isCourseApplicant tid ssh csh uid
+    guard isApplicant
+    return Authorized
+
+  r -> $unsupportedAuthPredicate AuthApplicant r
+  where
+    isCourseApplicant tid ssh csh uid = lift . $cachedHereBinary (uid, tid, ssh, csh) . E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do
+      E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
+      E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid
+           E.&&. course E.^. CourseTerm      E.==. E.val tid
+           E.&&. course E.^. CourseSchool    E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
+  CExamR tid ssh csh examn (ERegisterOccR occn) -> maybeT (unauthorizedI MsgExamOccurrenceNoCapacity) $ do
+    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    eid <- $cachedHereBinary (cid, examn) . MaybeT . getKeyBy $ UniqueExam cid examn
+    Entity occId ExamOccurrence{..} <- $cachedHereBinary (eid, occn) . MaybeT . getBy $ UniqueExamOccurrence eid occn
+    registered <- $cachedHereBinary occId . lift $ fromIntegral <$> count [ ExamRegistrationOccurrence ==. Just occId, ExamRegistrationExam ==. eid ]
+    guard $ examOccurrenceCapacity > registered
+    return Authorized
+  CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do
+    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    Entity tutId Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
+    registered <- $cachedHereBinary tutId . lift $ count [ TutorialParticipantTutorial ==. tutId ]
+    guard $ NTop tutorialCapacity > NTop (Just registered)
+    return Authorized
+  CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
+    Entity cid Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
+    registered <- $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
+    guard $ NTop courseCapacity > NTop (Just registered)
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthCapacity r
+tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of
+  CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do
+    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
+    case (tutorialRegGroup, mAuthId) of
+      (Nothing, _) -> return Authorized
+      (_, Nothing) -> return AuthenticationRequired
+      (Just rGroup, Just uid) -> do
+        hasOther <- $cachedHereBinary (uid, rGroup) . lift . E.selectExists . E.from $ \(tutorial `E.InnerJoin` participant) -> do
+          E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
+           E.&&. tutorial E.^. TutorialCourse E.==. E.val tutorialCourse
+           E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup)
+           E.&&. participant E.^. TutorialParticipantUser E.==. E.val uid
+        guard $ not hasOther
+        return Authorized
+  r -> $unsupportedAuthPredicate AuthRegisterGroup r
+tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> case route of
+  EExamListR -> exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do
+      E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam
+      E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId
+    guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty
+    return Authorized
+  CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
+    -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
+    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ]
+    assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do
+      E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
+      E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthEmpty r
+tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of
+  CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
+    Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
+    guard courseMaterialFree
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthMaterials r
+tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of
+  CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
+    sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthOwner r
+tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \mAuthId route _ -> case route of
+  CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . exceptT return return $ do
+    Entity shId Sheet{..} <- maybeTMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) $ do
+      cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh
+      MaybeT . $cachedHereBinary (cid, shn) . getBy $ CourseSheet cid shn
+    if | sheetAllowNonPersonalisedSubmission -> return Authorized
+       | otherwise -> do
+           authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+           flip guardMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) <=< $cachedHereBinary (shId, authId) . lift $
+             E.selectExists . E.from $ \psFile ->
+               E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. E.val shId
+                    E.&&. psFile E.^. PersonalisedSheetFileUser  E.==. E.val authId
+                    E.&&. E.not_ (E.isNothing $ psFile E.^. PersonalisedSheetFileContent) -- directories don't count
+           return Authorized
+  r -> $unsupportedAuthPredicate AuthPersonalisedSheetFiles r
+tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of
+  CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
+    sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+    sub <- MaybeT $ get sid
+    guard $ submissionRatingDone sub
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthRated r
+tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of
+  CSheetR tid ssh csh shn _ -> $cachedHereBinary (tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
+    Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
+    Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn
+    guard $ is _Just submissionModeUser
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthUserSubmissions r
+tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of
+  CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
+    Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
+    Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
+    guard submissionModeCorrector
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
+tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ do
+  referencedUser' <- case route of
+    AdminUserR cID -> return $ Left cID
+    AdminUserDeleteR cID -> return $ Left cID
+    AdminHijackUserR cID -> return $ Left cID
+    UserNotificationR cID -> return $ Left cID
+    UserPasswordR cID -> return $ Left cID
+    CourseR _ _ _ (CUserR cID) -> return $ Left cID
+    CApplicationR _ _ _ cID _ -> do
+      appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
+      CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId
+      return $ Right courseApplicationUser
+    _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
+  referencedUser <- case referencedUser' of
+    Right uid -> return uid
+    Left cID  -> catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
+  case mAuthId of
+    Just uid
+      | uid == referencedUser -> return Authorized
+    Nothing -> return AuthenticationRequired
+    _other  -> unauthorizedI MsgUnauthorizedSelf
+tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do
+  referencedUser <- case route of
+    AdminUserR cID -> return cID
+    AdminUserDeleteR cID -> return cID
+    AdminHijackUserR cID -> return cID
+    UserNotificationR cID -> return cID
+    UserPasswordR cID -> return cID
+    CourseR _ _ _ (CUserR cID) -> return cID
+    _other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route
+  referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
+  maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do
+    User{..} <- MaybeT $ get referencedUser'
+    guard $ userAuthentication == AuthLDAP
+  return Authorized
+tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ do
+  referencedUser <- case route of
+    AdminUserR cID -> return cID
+    AdminUserDeleteR cID -> return cID
+    AdminHijackUserR cID -> return cID
+    UserNotificationR cID -> return cID
+    UserPasswordR cID -> return cID
+    CourseR _ _ _ (CUserR cID) -> return cID
+    _other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route
+  referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
+  maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do
+    User{..} <- MaybeT $ get referencedUser'
+    guard $ is _AuthPWHash userAuthentication
+  return Authorized
+tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
+  MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
+    smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+    SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId
+    let isAuthenticated = isJust mAuthId
+    guard $ not systemMessageAuthenticatedOnly || isAuthenticated
+    return Authorized
+  MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
+    smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+    SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId
+    let isAuthenticated = isJust mAuthId
+    guard $ not systemMessageAuthenticatedOnly || isAuthenticated
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthAuthentication r
+tagAccessPredicate AuthRead = APPure $ \_ _ isWrite -> do
+  MsgRenderer mr <- ask
+  return $ bool Authorized (Unauthorized $ mr MsgUnauthorizedWrite) isWrite
+tagAccessPredicate AuthWrite = APPure $ \_ _ isWrite -> do
+  MsgRenderer mr <- ask
+  return $ bool (Unauthorized $ mr MsgUnauthorized) Authorized isWrite
+
+
+authTagSpecificity :: AuthTag -> AuthTag -> Ordering
+-- ^ Heuristic for which `AuthTag`s to evaluate first
+authTagSpecificity = comparing $ NTop . flip findIndex eqClasses . elem
+  where
+    eqClasses :: [[AuthTag]]
+    -- ^ Constructors of `AuthTag` ordered (increasing) by execution order
+    eqClasses =
+      [ [ AuthFree, AuthDeprecated, AuthDevelopment ] -- Route wide
+      , [ AuthRead, AuthWrite, AuthToken ] -- Request wide
+      , [ AuthAdmin ] -- Site wide
+      , [ AuthLecturer, AuthCourseRegistered, AuthParticipant, AuthCourseTime, AuthTime, AuthMaterials, AuthUserSubmissions, AuthCorrectorSubmissions, AuthCapacity, AuthEmpty ] ++ [ AuthSelf, AuthNoEscalation ] ++ [ AuthAuthentication ] -- Course/User/SystemMessage wide
+      , [ AuthCorrector ] ++ [ AuthTutor ] ++ [ AuthTutorialRegistered, AuthRegisterGroup ] -- Tutorial/Material/Sheet wide
+      , [ AuthOwner, AuthRated ] -- Submission wide
+      ]
+
+defaultAuthDNF :: AuthDNF
+defaultAuthDNF = PredDNF $ Set.fromList
+  [ impureNonNull . Set.singleton $ PLVariable AuthAdmin
+  , impureNonNull . Set.singleton $ PLVariable AuthToken
+  ]
+
+routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF
+-- ^ DNF up to entailment:
+--
+-- > (A_1 && A_2 && ...) OR' B OR' ...
+--
+-- > A OR' B := ((A |- B) ==> A) && (A || B)
+routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms defaultAuthDNF) . routeAttrs
+  where
+    partition' :: Set (Set AuthLiteral) -> Text -> Either InvalidAuthTag (Set (Set AuthLiteral))
+    partition' prev t
+      | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t)
+        = if
+           | oany (authTags `Set.isSubsetOf`) prev
+             -> Right prev
+           | otherwise
+             -> Right . Set.insert authTags $ Set.filter (not . (`Set.isSubsetOf` authTags)) prev
+      | otherwise
+        = Left $ InvalidAuthTag t
+
+evalAuthTags :: forall m. MonadAP m => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
+-- ^ `tell`s disabled predicates, identified as pivots
+evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite
+  = do
+      mr <- getMsgRenderer
+      let
+        authVarSpecificity = authTagSpecificity `on` plVar
+        authDNF = sortBy (authVarSpecificity `on` maximumBy authVarSpecificity . impureNonNull) $ map (sortBy authVarSpecificity) authDNF'
+
+        authTagIsInactive = not . authTagIsActive
+
+        evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult
+        evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite
+          where
+            evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do
+              $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
+              evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite'
+
+        evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult
+        evalAuthLiteral PLVariable{..} = evalAuthTag plVar
+        evalAuthLiteral PLNegated{..} = notAR mr plVar <$> evalAuthTag plVar
+
+        orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
+        orAR' = shortCircuitM (is _Authorized) (orAR mr)
+        andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
+
+        evalDNF :: [[AuthLiteral]] -> WriterT (Set AuthTag) m AuthResult
+        evalDNF = maybe (return $ falseAR mr) (ofoldr1 orAR') . fromNullable . map evalConj
+          where
+            evalConj = maybe (return $ trueAR mr) (ofoldr1 andAR') . fromNullable . map evalAuthLiteral
+
+      $logDebugS "evalAuthTags" . tshow . (route, isWrite, ) $ map (map $ id &&& authTagIsActive . plVar) authDNF
+
+      result <- evalDNF $ filter (all $ authTagIsActive . plVar) authDNF
+
+      unless (is _Authorized result) . forM_ (filter (any $ authTagIsInactive . plVar) authDNF) $ \conj ->
+        whenM (allM conj (\aTag -> (return . not . authTagIsActive $ plVar aTag) `or2M` (not . is _Unauthorized <$> evalAuthLiteral aTag))) $ do
+          let pivots = filter (authTagIsInactive . plVar) conj
+          whenM (allM pivots $ fmap (is _Authorized) . evalAuthLiteral) $ do
+            let pivots' = plVar <$> pivots
+            $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots'}|]
+            tell $ Set.fromList pivots'
+
+      return result
+
+evalAccessFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
+evalAccessFor mAuthId route isWrite = do
+  dnf <- either throwM return $ routeAuthTags route
+  fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite
+
+evalAccessForDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
+evalAccessForDB = evalAccessFor
+
+evalAccessWith :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult
+evalAccessWith assumptions route isWrite = do
+  mAuthId <- liftHandler maybeAuthId
+  tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
+  dnf <- either throwM return $ routeAuthTags route
+  let dnf' = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) $ Just dnf
+  case dnf' of
+    Nothing -> return Authorized
+    Just dnf'' -> do
+      (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf'' mAuthId route isWrite
+      result <$ tellSessionJson SessionInactiveAuthTags deactivated
+  
+evalAccessWithDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
+evalAccessWithDB = evalAccessWith
+
+evalAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> Bool -> m AuthResult
+evalAccess = evalAccessWith []
+
+evalAccessDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Route UniWorX -> Bool -> ReaderT backend m AuthResult
+evalAccessDB = evalAccess
+
+-- | Check whether the current user is authorized by `evalAccess` for the given route
+--   Convenience function for a commonly used code fragment
+hasAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> Bool -> m Bool
+hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite
+
+-- | Check whether the current user is authorized by `evalAccess` to read from the given route
+--   Convenience function for a commonly used code fragment
+hasReadAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> m Bool
+hasReadAccessTo = flip hasAccessTo False
+
+-- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route
+--   Convenience function for a commonly used code fragment
+hasWriteAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> m Bool
+hasWriteAccessTo = flip hasAccessTo True
+
+wouldHaveAccessTo :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX )
+                  => [(AuthTag, Bool)] -- ^ Assumptions
+                  -> Route UniWorX
+                  -> Bool
+                  -> m Bool
+wouldHaveAccessTo assumptions route isWrite = (== Authorized) <$> evalAccessWith assumptions route isWrite
+
+wouldHaveReadAccessTo, wouldHaveWriteAccessTo
+  :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX )
+  => [(AuthTag, Bool)] -- ^ Assumptions
+  -> Route UniWorX
+  -> m Bool
+wouldHaveReadAccessTo assumptions route = wouldHaveAccessTo assumptions route False
+wouldHaveWriteAccessTo assumptions route = wouldHaveAccessTo assumptions route True
+
+wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff
+  :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX )
+  => [(AuthTag, Bool)] -- ^ Assumptions
+  -> Route UniWorX
+  -> m Bool
+wouldHaveReadAccessToIff assumptions route = and2M (not <$> hasReadAccessTo route) $ wouldHaveReadAccessTo assumptions route
+wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo route) $ wouldHaveWriteAccessTo assumptions route
diff --git a/src/Foundation/DB.hs b/src/Foundation/DB.hs
new file mode 100644
index 000000000..5261af6a2
--- /dev/null
+++ b/src/Foundation/DB.hs
@@ -0,0 +1,46 @@
+module Foundation.DB
+  ( runDBRead
+  , runSqlPoolRetry
+  ) where
+
+import Import.NoFoundation hiding (runDB, getDBRunner)
+
+import Foundation.Type
+
+import qualified Control.Retry as Retry
+import GHC.IO.Exception (IOErrorType(OtherError))
+  
+import Database.Persist.Sql (runSqlPool, SqlReadBackend(..))
+
+  
+runSqlPoolRetry :: forall m a backend.
+                   ( MonadUnliftIO m, BackendCompatible SqlBackend backend
+                   , MonadLogger m, MonadMask m
+                   )
+                => ReaderT backend m a
+                -> Pool backend
+                -> m a
+runSqlPoolRetry action pool = do
+  let policy = Retry.fullJitterBackoff 1e3 & Retry.limitRetriesByCumulativeDelay 10e6
+      handlers = Retry.skipAsyncExceptions `snoc` Retry.logRetries suggestRetry logRetry
+        where suggestRetry :: IOException -> m Bool
+              suggestRetry ioExc = return $
+                   ioeGetErrorType ioExc == OtherError
+                && ioeGetLocation ioExc == "libpq"
+              logRetry :: forall e.
+                          Exception e
+                       => Bool -- ^ Will retry
+                       -> e
+                       -> Retry.RetryStatus
+                       -> m ()
+              logRetry shouldRetry@False err status = $logErrorS "runSqlPoolRetry" . pack $ Retry.defaultLogMsg shouldRetry err status
+              logRetry shouldRetry@True  err status = $logWarnS "runSqlPoolRetry" . pack $ Retry.defaultLogMsg shouldRetry err status
+
+  Retry.recovering policy handlers $ \Retry.RetryStatus{..} -> do
+    $logDebugS "runSqlPoolRetry" $ "rsIterNumber = " <> tshow rsIterNumber
+    runSqlPool action pool
+
+runDBRead :: ReaderT SqlReadBackend (HandlerFor UniWorX) a -> (HandlerFor UniWorX) a
+runDBRead action = do
+  $logDebugS "YesodPersist" "runDBRead"
+  runSqlPoolRetry (withReaderT SqlReadBackend action) . appConnPool =<< getYesod
diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs
index 57eebfeaa..aa514a72d 100644
--- a/src/Foundation/I18n.hs
+++ b/src/Foundation/I18n.hs
@@ -1,11 +1,12 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Foundation.I18n
-  ( appLanguages
+  ( appLanguages, appLanguagesOpts
   , UniWorXMessage(..)
   , ShortTermIdentifier(..)
   , MsgLanguage(..)
   , ShortSex(..)
+  , ShortWeekDay(..)
   , SheetTypeHeader(..)
   , SheetArchiveFileTypeDirectory(..)
   , ShortStudyDegree(..)
@@ -34,16 +35,17 @@ import qualified Data.Text as Text
 
 import Utils.Form
 
-import GHC.Exts (IsList(..))
+import qualified GHC.Exts (IsList(..))
 
 import Yesod.Form.I18n.German
 import Yesod.Form.I18n.English
 
-import qualified Data.Foldable as F
 import qualified Data.Char as Char
 import Text.Unidecode (unidecode)
 import Data.Text.Lens (packed)
 
+import Data.List ((!!))
+
 
 appLanguages :: NonEmpty Lang
 appLanguages = "de-de-formal" :| ["en-eu"]
@@ -183,6 +185,20 @@ instance RenderMessage UniWorX MsgLanguage where
     where
       mr = renderMessage foundation $ lang : filter (/= lang) ls
 
+appLanguagesOpts :: ( MonadHandler m
+                    , RenderMessage (HandlerSite m) MsgLanguage
+                    ) => m (OptionList Lang)
+-- ^ Authoritive list of supported Languages
+appLanguagesOpts = do
+  MsgRenderer mr <- getMsgRenderer
+  let mkOption l = Option
+        { optionDisplay = mr $ MsgLanguage l
+        , optionInternalValue = l
+        , optionExternalValue = l
+        }
+      langOptions = map mkOption $ toList appLanguages
+  return $ mkOptionList langOptions
+
 embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>)
 embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
 embedRenderMessage ''UniWorX ''StudyFieldType id
@@ -364,6 +380,23 @@ instance RenderMessage UniWorX (ValueRequired UniWorX) where
       mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
       mr = renderMessage foundation ls
 
+instance RenderRoute UniWorX => RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)) where
+  renderMessage f ls (UnsupportedAuthPredicate tag route) = mr . MsgUnsupportedAuthPredicate (mr tag) $ Text.intercalate "/" pieces
+    where
+      mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage f ls
+      (pieces, _) = renderRoute route
+
+instance RenderMessage UniWorX WeekDay where
+  renderMessage _ ls wDay = pack . fst $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7)
+
+newtype ShortWeekDay = ShortWeekDay { longWeekDay :: WeekDay }
+
+instance RenderMessage UniWorX ShortWeekDay where
+  renderMessage _ ls (ShortWeekDay wDay) = pack . snd $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7)
+
+embedRenderMessage ''UniWorX ''ButtonSubmit id
+
 
 unRenderMessage' :: (Eq a, Finite a, RenderMessage master a) => (Text -> Text -> Bool) -> master -> Text -> [a]
 unRenderMessage' cmp foundation inp = nub $ do
@@ -371,7 +404,7 @@ unRenderMessage' cmp foundation inp = nub $ do
   x <- universeF
   guard $ renderMessage foundation (l : filter (/= l) appLanguages') x `cmp` inp
   return x
-  where appLanguages' = F.toList appLanguages
+  where appLanguages' = toList appLanguages
 
 unRenderMessage :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a]
 unRenderMessage = unRenderMessage' (==)
@@ -379,3 +412,7 @@ unRenderMessage = unRenderMessage' (==)
 unRenderMessageLenient :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a]
 unRenderMessageLenient = unRenderMessage' cmp
   where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode)
+
+
+instance Default DateTimeFormatter where
+  def = mkDateTimeFormatter (getTimeLocale' []) def appTZ
diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs
new file mode 100644
index 000000000..a5d305981
--- /dev/null
+++ b/src/Foundation/Instances.hs
@@ -0,0 +1,203 @@
+{-# LANGUAGE UndecidableInstances #-} -- for `MonadCrypto` and `MonadSecretBox`
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Foundation.Instances
+  ( ButtonClass(..), YesodPersistBackend, AuthId, MonadCryptoKey
+  , unsafeHandler
+  ) where
+
+import Import.NoFoundation
+
+import qualified Data.Text as Text
+import qualified Data.List as List
+import Data.List (inits)
+
+import qualified Yesod.Core.Unsafe as Unsafe
+import qualified Yesod.Auth.Message as Auth
+
+import Utils.Form
+import Auth.LDAP
+import Auth.PWHash
+import Auth.Dummy
+
+import qualified Foundation.Yesod.Session as UniWorX
+import qualified Foundation.Yesod.Middleware as UniWorX
+import qualified Foundation.Yesod.ErrorHandler as UniWorX
+import qualified Foundation.Yesod.StaticContent as UniWorX
+import qualified Foundation.Yesod.Persist as UniWorX
+import qualified Foundation.Yesod.Auth as UniWorX
+
+import Foundation.SiteLayout
+import Foundation.Type
+import Foundation.I18n
+import Foundation.Authorization
+import Foundation.Yesod.Auth hiding (authenticate)
+import Foundation.Routes
+import Foundation.DB
+
+import Network.Wai.Parse (lbsBackEnd)
+
+import Control.Monad.Writer.Class (MonadWriter(..))
+import UnliftIO.Pool (withResource)
+
+
+data instance ButtonClass UniWorX
+  = BCIsButton
+  | BCDefault
+  | BCPrimary
+  | BCSuccess
+  | BCInfo
+  | BCWarning
+  | BCDanger
+  | BCLink
+  | BCMassInputAdd | BCMassInputDelete
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+instance PathPiece (ButtonClass UniWorX) where
+  toPathPiece BCIsButton = "btn"
+  toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass
+  fromPathPiece = flip List.lookup $ map (toPathPiece &&& id) universeF
+
+instance Button UniWorX ButtonSubmit where
+  btnClasses BtnSubmit = [BCIsButton, BCPrimary]
+
+
+
+-- Please see the documentation for the Yesod typeclass. There are a number
+-- of settings which can be configured by overriding methods here.
+instance Yesod UniWorX where
+    -- Controls the base of generated URLs. For more information on modifying,
+    -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
+    approot = ApprootRequest $ \app req ->
+        case app ^. _appRoot of
+            Nothing -> getApprootText guessApproot app req
+            Just root -> root
+
+    makeSessionBackend = UniWorX.makeSessionBackend
+
+    maximumContentLength app _ = app ^. _appMaximumContentLength
+
+    -- Yesod Middleware allows you to run code before and after each handler function.
+    -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
+    -- Some users may also want to add the defaultCsrfMiddleware, which:
+    --   a) Sets a cookie with a CSRF token in it.
+    --   b) Validates that incoming write requests include that token in either a header or POST parameter.
+    -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
+    -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
+    yesodMiddleware = UniWorX.yesodMiddleware
+
+    -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget`
+    defaultMessageWidget _title _body = error "defaultMessageWidget: undefined"
+
+    errorHandler = UniWorX.errorHandler
+
+    defaultLayout = siteLayout' Nothing
+
+    -- The page to be redirected to when authentication is required.
+    authRoute _ = Just $ AuthR LoginR
+
+    isAuthorized = evalAccess
+
+    addStaticContent = UniWorX.addStaticContent
+
+    fileUpload _site _length = FileUploadMemory lbsBackEnd
+
+    -- What messages should be logged. The following includes all messages when
+    -- in development, and warnings and errors in production.
+    shouldLogIO app _source level = do
+      LogSettings{..} <- readTVarIO $ appLogSettings app
+      return $ logAll || level >= logMinimumLevel
+
+    makeLogger = readTVarIO . snd . appLogger
+
+unsafeHandler :: UniWorX -> HandlerFor UniWorX a -> IO a
+unsafeHandler f h = do
+  logger <- makeLogger f
+  Unsafe.fakeHandlerGetLogger (const logger) f h
+
+
+-- How to run database actions.
+instance YesodPersist UniWorX where
+    type YesodPersistBackend UniWorX = SqlBackend
+    runDB = UniWorX.runDB
+
+instance YesodPersistRunner UniWorX where
+    getDBRunner = UniWorX.getDBRunner
+
+    
+instance YesodAuth UniWorX where
+    type AuthId UniWorX = UserId
+
+    -- Where to send a user after successful login
+    loginDest _ = NewsR
+    -- Where to send a user after logout
+    logoutDest _ = NewsR
+    -- Override the above two destinations when a Referer: header is present
+    redirectToReferer _ = True
+
+    loginHandler = do
+      toParent <- getRouteToParent
+      liftHandler . defaultLayout $ do
+        plugins <- getsYesod authPlugins
+        $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins)
+
+        setTitleI MsgLoginTitle
+        $(widgetFile "login")
+
+    authenticate = UniWorX.authenticate
+
+    authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool } = catMaybes
+      [ flip campusLogin campusUserFailoverMode <$> appLdapPool
+      , Just . hashLogin $ pwHashAlgorithm appAuthPWHash
+      , dummyLogin <$ guard appAuthDummyLogin
+      ]
+
+    authHttpManager = getsYesod appHttpManager
+
+    onLogin = liftHandler $ do
+      mlang <- runDB $ updateUserLanguage Nothing
+      app <- getYesod
+      let mr | Just lang <- mlang = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang
+             | otherwise = renderMessage app []
+      addMessage Success . toHtml $ mr Auth.NowLoggedIn
+
+    onErrorHtml dest msg = do
+      addMessage Error $ toHtml msg
+      redirect dest
+
+    renderAuthMessage _ ls = case lang of
+      ("en" : _) -> Auth.englishMessage
+      _other     -> Auth.germanMessage
+      where lang = Text.splitOn "-" $ selectLanguage' appLanguages ls
+
+instance YesodAuthPersist UniWorX where
+  getAuthEntity = liftHandler . runDBRead . get
+
+    
+instance YesodMail UniWorX where
+  defaultFromAddress = getsYesod $ view _appMailFrom
+  mailObjectIdDomain = getsYesod $ view _appMailObjectDomain
+  mailVerp = getsYesod $ view _appMailVerp
+  mailDateTZ = return appTZ
+  mailSmtp act = do
+    pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
+    withResource pool act
+  mailT ctx mail = defMailT ctx $ do
+    void setMailObjectIdRandom
+    setDateCurrent
+    replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail)
+
+    (mRes, smtpData) <- listen mail
+    unless (view _MailSmtpDataSet smtpData)
+      setMailSmtpData
+
+    return mRes
+
+
+instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
+  type MonadCryptoKey m = CryptoIDKey
+  cryptoIDKey f = getsYesod appCryptoIDKey >>= f
+
+instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadSecretBox m where
+  secretBoxKey = getsYesod appSecretBoxKey
diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs
new file mode 100644
index 000000000..b1a242f0a
--- /dev/null
+++ b/src/Foundation/Navigation.hs
@@ -0,0 +1,2239 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-# LANGUAGE UndecidableInstances #-} -- for `ChildrenNavChildren`
+{-# LANGUAGE DuplicateRecordFields #-} -- for `navLabel`
+
+module Foundation.Navigation
+  ( NavQuickView(..), NavType(..), NavLevel(..), NavHeaderRole(..), NavLink(..), Nav(..), NavChildren
+  , _navModal, _navMethod, _navData, _navLabel, _navType, _navForceActive, _navHeaderRole, _navIcon, _navLink, _navChildren
+  , _NavHeader, _NavHeaderContainer, _NavPageActionPrimary, _NavPageActionSecondary, _NavFooter
+  , pageActions
+  , pageQuickActions
+  , defaultLinks
+  , navAccess
+  , navQuick
+  , evalAccessCorrector
+  ) where
+
+import Import.NoFoundation
+
+import Foundation.Type
+import Foundation.Routes
+import Foundation.I18n
+import Foundation.Authorization
+import Foundation.DB
+
+import Handler.Utils.Memcached
+import Handler.Utils.ExamOffice.Course
+import Utils.Sheet
+
+import qualified Data.CaseInsensitive as CI
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+import Control.Monad.Trans.State (execStateT)
+
+import Yesod.Core.Types (HandlerContents)
+
+
+-- Define breadcrumbs.
+i18nCrumb :: (RenderMessage (HandlerSite m) msg, MonadHandler m)
+          => msg
+          -> Maybe (Route (HandlerSite m))
+          -> m (Text, Maybe (Route (HandlerSite m)))
+i18nCrumb msg mbR = do
+  mr <- getMessageRender
+  return (mr msg, mbR)
+
+-- `breadcrumb` _really_ needs to be total for _all_ routes
+--
+-- Even if routes are POST only or don't usually use `siteLayout` they will if
+-- an error occurs.
+--
+-- Keep in mind that Breadcrumbs are also shown by the 403-Handler,
+-- 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 BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
+  breadcrumb (AuthR _)        = i18nCrumb MsgMenuLogin         $ Just NewsR
+  breadcrumb (StaticR _)      = i18nCrumb MsgBreadcrumbStatic    Nothing
+  breadcrumb (WellKnownR _)   = i18nCrumb MsgBreadcrumbWellKnown Nothing
+  breadcrumb MetricsR         = i18nCrumb MsgBreadcrumbMetrics   Nothing
+
+  breadcrumb NewsR            = i18nCrumb MsgMenuNews      Nothing
+  breadcrumb UsersR           = i18nCrumb MsgMenuUsers   $ Just AdminR
+  breadcrumb AdminUserAddR    = i18nCrumb MsgMenuUserAdd $ Just UsersR
+  breadcrumb (AdminUserR cID) = maybeT (i18nCrumb MsgBreadcrumbUser $ Just UsersR) $ do
+    guardM . hasReadAccessTo $ AdminUserR cID
+    uid <- decrypt cID
+    User{..} <- MaybeT . runDBRead $ get uid
+    return (userDisplayName, Just UsersR)
+  breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID
+  breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID
+  breadcrumb (UserNotificationR cID) = do
+    mayList <- hasReadAccessTo UsersR
+    if
+      | mayList
+        -> i18nCrumb MsgMenuUserNotifications . Just $ AdminUserR cID
+      | otherwise
+        -> i18nCrumb MsgMenuUserNotifications $ Just ProfileR
+  breadcrumb (UserPasswordR cID) = do
+    mayList <- hasReadAccessTo UsersR
+    if
+      | mayList
+        -> i18nCrumb MsgMenuUserPassword . Just $ AdminUserR cID
+      | otherwise
+        -> i18nCrumb MsgMenuUserPassword $ Just ProfileR
+  breadcrumb AdminNewFunctionaryInviteR = i18nCrumb MsgMenuLecturerInvite $ Just UsersR
+  breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing
+
+  breadcrumb AdminR           = i18nCrumb MsgAdminHeading           Nothing
+  breadcrumb AdminFeaturesR   = i18nCrumb MsgAdminFeaturesHeading $ Just AdminR
+  breadcrumb AdminTestR       = i18nCrumb MsgMenuAdminTest        $ Just AdminR
+  breadcrumb AdminErrMsgR     = i18nCrumb MsgMenuAdminErrMsg      $ Just AdminR
+  breadcrumb AdminTokensR     = i18nCrumb MsgMenuAdminTokens      $ Just AdminR
+  breadcrumb AdminCrontabR    = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
+
+  breadcrumb SchoolListR      = i18nCrumb MsgMenuSchoolList       $ Just AdminR
+  breadcrumb (SchoolR ssh SchoolEditR) = maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
+    School{..} <- MaybeT . runDBRead $ get ssh
+    return (CI.original schoolName, Just SchoolListR)
+  breadcrumb SchoolNewR       = i18nCrumb MsgMenuSchoolNew        $ Just SchoolListR
+
+  breadcrumb (ExamOfficeR EOExamsR)  = i18nCrumb MsgMenuExamOfficeExams    Nothing
+  breadcrumb (ExamOfficeR EOFieldsR) = i18nCrumb MsgMenuExamOfficeFields . Just $ ExamOfficeR EOExamsR
+  breadcrumb (ExamOfficeR EOUsersR)  = i18nCrumb MsgMenuExamOfficeUsers . Just $ ExamOfficeR EOExamsR
+  breadcrumb (ExamOfficeR EOUsersInviteR) = i18nCrumb MsgBreadcrumbExamOfficeUserInvite Nothing
+
+  breadcrumb InfoR            = i18nCrumb MsgMenuInformation     Nothing
+  breadcrumb InfoLecturerR    = i18nCrumb MsgInfoLecturerTitle $ Just InfoR
+  breadcrumb LegalR           = i18nCrumb MsgMenuLegal         $ Just InfoR
+  breadcrumb InfoAllocationR  = i18nCrumb MsgBreadcrumbAllocationInfo $ Just InfoR
+  breadcrumb VersionR         = i18nCrumb MsgMenuVersion       $ Just InfoR
+  breadcrumb FaqR             = i18nCrumb MsgBreadcrumbFaq     $ Just InfoR
+
+
+  breadcrumb HelpR            = i18nCrumb MsgMenuHelp            Nothing
+
+
+  breadcrumb HealthR          = i18nCrumb MsgMenuHealth          Nothing
+  breadcrumb InstanceR        = i18nCrumb MsgMenuInstance        Nothing
+
+  breadcrumb ProfileR         = i18nCrumb MsgBreadcrumbProfile   Nothing
+  breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail  $ Just ProfileR
+  breadcrumb ProfileDataR     = i18nCrumb MsgMenuProfileData   $ Just ProfileR
+  breadcrumb AuthPredsR       = i18nCrumb MsgMenuAuthPreds     $ Just ProfileR
+  breadcrumb CsvOptionsR      = i18nCrumb MsgCsvOptions        $ Just ProfileR
+  breadcrumb LangR            = i18nCrumb MsgMenuLanguage      $ Just ProfileR
+
+  breadcrumb StorageKeyR      = i18nCrumb MsgBreadcrumbStorageKey Nothing
+
+  breadcrumb TermShowR              = i18nCrumb MsgMenuTermShow    $ Just NewsR
+  breadcrumb TermCurrentR           = i18nCrumb MsgMenuTermCurrent $ Just TermShowR
+  breadcrumb TermEditR              = i18nCrumb MsgMenuTermCreate  $ Just TermShowR
+  breadcrumb (TermEditExistR tid)   = i18nCrumb MsgMenuTermEdit    . Just $ TermCourseListR tid
+  breadcrumb (TermCourseListR tid)  = maybeT (i18nCrumb MsgBreadcrumbTerm $ Just CourseListR) $ do -- redirect only, used in other breadcrumbs
+    guardM . lift . runDBRead $ isJust <$> get tid
+    i18nCrumb (ShortTermIdentifier $ unTermKey tid) $ Just CourseListR
+
+  breadcrumb (TermSchoolCourseListR tid ssh) = maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ TermCourseListR tid) $ do -- redirect only, used in other breadcrumbs
+    guardM . lift . runDBRead $
+      (&&) <$> fmap isJust (get ssh)
+           <*> fmap isJust (get tid)
+    return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid)
+
+  breadcrumb AllocationListR        = i18nCrumb MsgAllocationListTitle $ Just NewsR
+  breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of
+    AShowR      -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do
+      mr <- getMessageRender
+      Entity _ Allocation{allocationName} <- MaybeT . runDBRead . getBy $ TermSchoolAllocationShort tid ssh ash
+      return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just AllocationListR)
+    ARegisterR  -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR
+    AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do
+      cid <- decrypt cID
+      Course{..} <- hoist runDBRead $ do
+        aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash
+        guardM . lift $ exists [ AllocationCourseAllocation ==. aid, AllocationCourseCourse ==. cid ]
+        MaybeT $ get cid
+      return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR)
+    AUsersR     -> i18nCrumb MsgBreadcrumbAllocationUsers . Just $ AllocationR tid ssh ash AShowR
+    APriosR     -> i18nCrumb MsgBreadcrumbAllocationPriorities . Just $ AllocationR tid ssh ash AUsersR
+    AComputeR   -> i18nCrumb MsgBreadcrumbAllocationCompute . Just $ AllocationR tid ssh ash AUsersR
+    AAcceptR    -> i18nCrumb MsgBreadcrumbAllocationAccept . Just $ AllocationR tid ssh ash AUsersR
+
+  breadcrumb ParticipantsListR      = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR
+  breadcrumb (ParticipantsR _ _)    = i18nCrumb MsgBreadcrumbParticipants     $ Just ParticipantsListR
+  breadcrumb ParticipantsIntersectR = i18nCrumb MsgMenuParticipantsIntersect  $ Just ParticipantsListR
+
+  breadcrumb  CourseListR                 = i18nCrumb MsgMenuCourseList   Nothing
+  breadcrumb  CourseNewR                  = i18nCrumb MsgMenuCourseNew  $ Just CourseListR
+  breadcrumb (CourseR tid ssh csh CShowR) = maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ TermSchoolCourseListR tid ssh) $ do
+    guardM . lift . runDBRead . existsBy $ TermSchoolCourseShort tid ssh csh
+    return (CI.original csh, Just $ TermSchoolCourseListR tid ssh)
+  breadcrumb (CourseR tid ssh csh CEditR)     = i18nCrumb MsgMenuCourseEdit . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh CUsersR)    = i18nCrumb MsgMenuCourseMembers . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh CAddUserR)  = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR
+  breadcrumb (CourseR tid ssh csh CInviteR)   = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh (CUserR cID)) = maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do
+    guardM . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID
+    uid <- decrypt cID
+    User{userDisplayName} <- MaybeT . runDBRead $ get uid
+    return (userDisplayName, Just $ CourseR tid ssh csh CUsersR)
+  breadcrumb (CourseR tid ssh csh CCorrectionsR) = i18nCrumb MsgMenuSubmissions . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh CAssignR)   = i18nCrumb MsgMenuCorrectionsAssign . Just $ CourseR tid ssh csh CCorrectionsR
+  breadcrumb (CourseR tid ssh csh SheetListR) = i18nCrumb MsgMenuSheetList . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh SheetNewR ) = i18nCrumb MsgMenuSheetNew . Just $ CourseR tid ssh csh SheetListR
+  breadcrumb (CourseR tid ssh csh SheetCurrentR) = i18nCrumb MsgMenuSheetCurrent . Just $ CourseR tid ssh csh SheetListR
+  breadcrumb (CourseR tid ssh csh SheetOldUnassignedR) = i18nCrumb MsgMenuSheetOldUnassigned . Just $ CourseR tid ssh csh SheetListR
+  breadcrumb (CourseR tid ssh csh CCommR    ) = i18nCrumb MsgMenuCourseCommunication . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh CTutorialListR) = i18nCrumb MsgMenuTutorialList . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh CTutorialNewR) = i18nCrumb MsgMenuTutorialNew . Just $ CourseR tid ssh csh CTutorialListR
+  breadcrumb (CourseR tid ssh csh CFavouriteR) = i18nCrumb MsgBreadcrumbCourseFavourite . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh CRegisterR)  = i18nCrumb MsgBreadcrumbCourseRegister . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh CRegisterTemplateR) = i18nCrumb MsgBreadcrumbCourseRegisterTemplate . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh CLecInviteR) = i18nCrumb MsgBreadcrumbLecturerInvite . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh CDeleteR) = i18nCrumb MsgMenuCourseDelete . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh CHiWisR) = i18nCrumb MsgBreadcrumbHiWis . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh CNotesR) = i18nCrumb MsgBreadcrumbCourseNotes . Just $ CourseR tid ssh csh CShowR
+
+  breadcrumb (CourseR tid ssh csh CNewsNewR)    = i18nCrumb MsgMenuCourseNewsNew . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh (CourseNewsR cID sRoute)) = case sRoute of
+    CNShowR   -> i18nCrumb MsgBreadcrumbCourseNews . Just $ CourseR tid ssh csh CShowR
+    CNEditR   -> i18nCrumb MsgMenuCourseNewsEdit . Just $ CNewsR tid ssh csh cID CNShowR
+    CNDeleteR -> i18nCrumb MsgBreadcrumbCourseNewsDelete . Just $ CNewsR tid ssh csh cID CNShowR
+    CNArchiveR -> i18nCrumb MsgBreadcrumbCourseNewsArchive . Just $ CNewsR tid ssh csh cID CNShowR
+    CNFileR _ -> i18nCrumb MsgBreadcrumbCourseNewsFile . Just $ CNewsR tid ssh csh cID CNShowR
+
+  breadcrumb (CourseR tid ssh csh CEventsNewR)    = i18nCrumb MsgMenuCourseEventNew . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh (CourseEventR _cID sRoute)) = case sRoute of
+    CEvEditR   -> i18nCrumb MsgMenuCourseEventEdit . Just $ CourseR tid ssh csh CShowR
+    CEvDeleteR -> i18nCrumb MsgBreadcrumbCourseEventDelete . Just $ CourseR tid ssh csh CShowR
+
+  breadcrumb (CourseR tid ssh csh CExamListR) = i18nCrumb MsgMenuExamList . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh CExamNewR) = i18nCrumb MsgMenuExamNew . Just $ CourseR tid ssh csh CExamListR
+
+  breadcrumb (CourseR tid ssh csh CApplicationsR) = i18nCrumb MsgMenuCourseApplications . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh CAppsFilesR) = i18nCrumb MsgBreadcrumbCourseAppsFiles . Just $ CourseR tid ssh csh CApplicationsR
+
+  breadcrumb (CourseR tid ssh csh (CourseApplicationR cID sRoute)) = case sRoute of
+    CAEditR -> maybeT (i18nCrumb MsgBreadcrumbApplicant . Just $ CourseR tid ssh csh CApplicationsR) $ do
+      guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR
+      appId <- decrypt cID
+      User{..} <- hoist runDBRead $ MaybeT (get appId) >>= MaybeT . get . courseApplicationUser
+      return (userDisplayName, Just $ CourseR tid ssh csh CApplicationsR)
+    CAFilesR -> i18nCrumb MsgBreadcrumbApplicationFiles . Just $ CApplicationR tid ssh csh cID CAEditR
+
+  breadcrumb (CourseR tid ssh csh (ExamR examn sRoute)) = case sRoute of
+    EShowR    -> maybeT (i18nCrumb MsgBreadcrumbExam . Just $ CourseR tid ssh csh CExamListR) $ do
+      guardM . hasReadAccessTo $ CExamR tid ssh csh examn EShowR
+      return (CI.original examn, Just $ CourseR tid ssh csh CExamListR)
+    EEditR    -> i18nCrumb MsgMenuExamEdit . Just $ CExamR tid ssh csh examn EShowR
+    EUsersR   -> i18nCrumb MsgMenuExamUsers . Just $ CExamR tid ssh csh examn EShowR
+    EAddUserR -> i18nCrumb MsgMenuExamAddMembers . Just $ CExamR tid ssh csh examn EUsersR
+    EGradesR  -> i18nCrumb MsgMenuExamGrades . Just $ CExamR tid ssh csh examn EShowR
+    ECInviteR  -> i18nCrumb MsgBreadcrumbExamCorrectorInvite . Just $ CExamR tid ssh csh examn EShowR
+    EInviteR   -> i18nCrumb MsgBreadcrumbExamParticipantInvite . Just $ CExamR tid ssh csh examn EShowR
+    ERegisterR -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR
+    ERegisterOccR _occn -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR
+    EAutoOccurrenceR -> i18nCrumb MsgBreadcrumbExamAutoOccurrence . Just $ CExamR tid ssh csh examn EUsersR
+    ECorrectR  -> i18nCrumb MsgMenuExamCorrect . Just $ CExamR tid ssh csh examn EShowR
+
+  breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of
+    TUsersR  -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do
+      guardM . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR
+      return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR)
+    TEditR   -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR
+    TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR
+    TCommR   -> i18nCrumb MsgMenuTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR
+    TRegisterR -> i18nCrumb MsgBreadcrumbTutorialRegister . Just $ CourseR tid ssh csh CShowR
+    TInviteR -> i18nCrumb MsgBreadcrumbTutorInvite . Just $ CTutorialR tid ssh csh tutn TUsersR
+
+  breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of
+    SShowR -> maybeT (i18nCrumb MsgBreadcrumbSheet . Just $ CourseR tid ssh csh SheetListR) $ do
+      guardM . hasReadAccessTo $ CSheetR tid ssh csh shn SShowR
+      return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
+    SEditR -> i18nCrumb MsgMenuSheetEdit . Just $ CSheetR tid ssh csh shn SShowR
+    SDelR  -> i18nCrumb MsgMenuSheetDelete . Just $ CSheetR tid ssh csh shn SShowR
+    SSubsR -> i18nCrumb MsgMenuSubmissions . Just $ CSheetR tid ssh csh shn SShowR
+    SAssignR -> i18nCrumb MsgMenuCorrectionsAssign . Just $ CSheetR tid ssh csh shn SSubsR
+    SubmissionNewR -> i18nCrumb MsgMenuSubmissionNew . Just $ CSheetR tid ssh csh shn SShowR
+    SubmissionOwnR -> i18nCrumb MsgMenuSubmissionOwn . Just $ CSheetR tid ssh csh shn SShowR
+    SubmissionR cid sRoute' -> case sRoute' of
+      SubShowR -> do
+        mayList <- hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR
+        if
+          | mayList
+            -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SSubsR
+          | otherwise
+            -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SShowR
+      CorrectionR -> i18nCrumb MsgMenuCorrection . Just $ CSubmissionR tid ssh csh shn cid SubShowR
+      SubDelR -> i18nCrumb MsgMenuSubmissionDelete . Just $ CSubmissionR tid ssh csh shn cid SubShowR
+      SubAssignR -> i18nCrumb MsgCorrectorAssignTitle . Just $ CSubmissionR tid ssh csh shn cid SubShowR
+      SInviteR -> i18nCrumb MsgBreadcrumbSubmissionUserInvite . Just $ CSubmissionR tid ssh csh shn cid SubShowR
+      SubArchiveR sft -> i18nCrumb sft . Just $ CSubmissionR tid ssh csh shn cid SubShowR
+      SubDownloadR _ _ -> i18nCrumb MsgBreadcrumbSubmissionFile . Just $ CSubmissionR tid ssh csh shn cid SubShowR
+    SArchiveR -> i18nCrumb MsgBreadcrumbSheetArchive . Just $ CSheetR tid ssh csh shn SShowR
+    SIsCorrR -> i18nCrumb MsgBreadcrumbSheetIsCorrector . Just $ CSheetR tid ssh csh shn SShowR
+    SPseudonymR -> i18nCrumb MsgBreadcrumbSheetPseudonym . Just $ CSheetR tid ssh csh shn SShowR
+    SCorrInviteR -> i18nCrumb MsgBreadcrumbSheetCorrectorInvite . Just $ CSheetR tid ssh csh shn SShowR
+    SZipR sft -> i18nCrumb sft . Just $ CSheetR tid ssh csh shn SShowR
+    SFileR _ _ -> i18nCrumb MsgBreadcrumbSheetFile . Just $ CSheetR tid ssh csh shn SShowR
+    SPersonalFilesR -> i18nCrumb MsgBreadcrumbSheetPersonalisedFiles . Just $ CSheetR tid ssh csh shn SShowR
+
+  breadcrumb (CourseR tid ssh csh MaterialListR) = i18nCrumb MsgMenuMaterialList . Just $ CourseR tid ssh csh CShowR
+  breadcrumb (CourseR tid ssh csh MaterialNewR ) = i18nCrumb MsgMenuMaterialNew . Just $ CourseR tid ssh csh MaterialListR
+  breadcrumb (CourseR tid ssh csh (MaterialR mnm sRoute)) = case sRoute of
+    MShowR -> maybeT (i18nCrumb MsgBreadcrumbMaterial . Just $ CourseR tid ssh csh MaterialListR) $ do
+      guardM . hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR
+      return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR)
+    MEditR -> i18nCrumb MsgMenuMaterialEdit . Just $ CMaterialR tid ssh csh mnm MShowR
+    MDelR  -> i18nCrumb MsgMenuMaterialDelete . Just $ CMaterialR tid ssh csh mnm MShowR
+    MArchiveR -> i18nCrumb MsgBreadcrumbMaterialArchive . Just $ CMaterialR tid ssh csh mnm MShowR
+    MFileR _ -> i18nCrumb MsgBreadcrumbMaterialFile . Just $ CMaterialR tid ssh csh mnm MShowR
+
+  breadcrumb (CourseR tid ssh csh CPersonalFilesR) = i18nCrumb MsgBreadcrumbCourseSheetPersonalisedFiles . Just $ CourseR tid ssh csh CShowR
+
+  breadcrumb CorrectionsR         = i18nCrumb MsgMenuCorrections Nothing
+  breadcrumb CorrectionsUploadR   = i18nCrumb MsgMenuCorrectionsUpload $ Just CorrectionsR
+  breadcrumb CorrectionsCreateR   = i18nCrumb MsgMenuCorrectionsCreate $ Just CorrectionsR
+  breadcrumb CorrectionsGradeR    = i18nCrumb MsgMenuCorrectionsGrade $ Just CorrectionsR
+  breadcrumb CorrectionsDownloadR = i18nCrumb MsgMenuCorrectionsDownload $ Just CorrectionsR
+
+  breadcrumb (CryptoUUIDDispatchR _) = i18nCrumb MsgBreadcrumbCryptoIDDispatch Nothing
+
+  breadcrumb (MessageR _) = do
+    mayList <- (== Authorized) <$> evalAccess MessageListR False
+    if
+      | mayList   -> i18nCrumb MsgBreadcrumbSystemMessage $ Just MessageListR
+      | otherwise -> i18nCrumb MsgBreadcrumbSystemMessage $ Just NewsR
+  breadcrumb MessageListR = i18nCrumb MsgMenuMessageList $ Just AdminR
+  breadcrumb (MessageHideR cID) = i18nCrumb MsgBreadcrumbMessageHide . Just $ MessageR cID
+
+  breadcrumb GlossaryR = i18nCrumb MsgMenuGlossary $ Just InfoR
+
+  breadcrumb EExamListR = i18nCrumb MsgMenuExternalExamList Nothing
+  breadcrumb EExamNewR = do
+    isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR
+    i18nCrumb MsgBreadcrumbExternalExamNew . Just $ if
+      | isEO -> ExamOfficeR EOExamsR
+      | otherwise -> EExamListR
+  breadcrumb (EExamR tid ssh coursen examn sRoute) = case sRoute of
+    EEShowR -> do
+      isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR
+      maybeT (i18nCrumb MsgBreadcrumbExternalExam . Just $ bool EExamListR (ExamOfficeR EOExamsR) isEO) $ do
+        guardM . hasReadAccessTo $ EExamR tid ssh coursen examn EEShowR
+        i18nCrumb (MsgBreadcrumbExternalExamShow coursen examn) . Just $ if
+          | isEO -> ExamOfficeR EOExamsR
+          | otherwise -> EExamListR
+    EEEditR -> i18nCrumb MsgBreadcrumbExternalExamEdit . Just $ EExamR tid ssh coursen examn EEShowR
+    EEUsersR -> i18nCrumb MsgBreadcrumbExternalExamUsers . Just $ EExamR tid ssh coursen examn EEShowR
+    EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR
+    EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR
+
+
+data NavQuickView
+  = NavQuickViewFavourite
+  | NavQuickViewPageActionSecondary
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+  deriving (Universe, Finite)
+
+navQuick :: NavQuickView -> (NavQuickView -> Any)
+navQuick x x' = Any $ x == x'
+
+data NavType
+  = NavTypeLink
+    { navModal  :: Bool
+    }
+  | NavTypeButton
+    { navMethod :: StdMethod
+    , navData   :: [(Text, Text)]
+    }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Binary)
+
+makeLenses_ ''NavType
+makePrisms ''NavType
+
+data NavLevel = NavLevelTop | NavLevelInner
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+
+data NavHeaderRole = NavHeaderPrimary | NavHeaderSecondary
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+
+data NavLink = forall msg route. (RenderMessage UniWorX msg, HasRoute UniWorX route, RedirectUrl UniWorX route) => NavLink
+  { navLabel       :: msg
+  , navRoute       :: route
+  , navAccess'     :: Handler Bool
+  , navType        :: NavType
+  , navQuick'      :: NavQuickView -> Any
+  , navForceActive :: Bool
+  }
+
+makeLenses_ ''NavLink
+
+instance HasRoute UniWorX NavLink where
+  urlRoute NavLink{..} = urlRoute navRoute
+instance RedirectUrl UniWorX NavLink where
+  toTextUrl NavLink{..} = toTextUrl navRoute
+instance RenderMessage UniWorX NavLink where
+  renderMessage app ls NavLink{..} = renderMessage app ls navLabel
+
+data Nav
+  = NavHeader
+    { navHeaderRole :: NavHeaderRole
+    , navIcon       :: Icon
+    , navLink       :: NavLink
+    }
+  | NavHeaderContainer
+    { navHeaderRole :: NavHeaderRole
+    , navLabel      :: SomeMessage UniWorX
+    , navIcon       :: Icon
+    , navChildren   :: [NavLink]
+    }
+  | NavPageActionPrimary
+    { navLink     :: NavLink
+    , navChildren :: [NavLink]
+    }
+  | NavPageActionSecondary
+    { navLink :: NavLink
+    }
+  | NavFooter
+    { navLink :: NavLink
+    } deriving (Generic, Typeable)
+
+makeLenses_ ''Nav
+makePrisms ''Nav
+
+data NavChildren
+type instance Children NavChildren a = ChildrenNavChildren a
+type family ChildrenNavChildren a where
+  ChildrenNavChildren (SomeMessage UniWorX) = '[]
+
+  ChildrenNavChildren a = Children ChGeneric a
+
+navAccess :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX) => Nav -> MaybeT m Nav
+navAccess = execStateT $ do
+  guardM $ preuse _navLink >>= maybe (return True) navLinkAccess
+
+  _navChildren <~ (filterM navLinkAccess =<< use _navChildren)
+  whenM (hasn't _navLink <$> use id) $
+    guardM $ not . null <$> use _navChildren
+
+navLinkAccess :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX) => NavLink -> m Bool
+navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M` accessCheck navType navRoute
+  where
+    shortCircuit :: HandlerContents -> m Bool
+    shortCircuit _ = return False
+
+    accessCheck :: HasRoute UniWorX route => NavType -> route -> m Bool
+    accessCheck nt (urlRoute -> route) = do
+      authCtx <- getAuthContext
+      $memcachedByHere (Just $ Right 120) (authCtx, nt, route) $
+        bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route
+  
+defaultLinks :: (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => m [Nav]
+defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header.
+  [ return NavHeader
+      { navHeaderRole = NavHeaderSecondary
+      , navIcon       = IconMenuLogout
+      , navLink       = NavLink
+        { navLabel       = MsgMenuLogout
+        , navRoute       = AuthR LogoutR
+        , navAccess'     = is _Just <$> maybeAuthId
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      }
+  , return NavHeader
+      { navHeaderRole = NavHeaderSecondary
+      , navIcon       = IconMenuLogin
+      , navLink       = NavLink
+        { navLabel       = MsgMenuLogin
+        , navRoute       = AuthR LoginR
+        , navAccess'     = is _Nothing <$> maybeAuthId
+        , navType        = NavTypeLink { navModal = True }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      }
+  , return NavHeader
+      { navHeaderRole = NavHeaderSecondary
+      , navIcon       = IconMenuProfile
+      , navLink       = NavLink
+        { navLabel       = MsgMenuProfile
+        , navRoute       = ProfileR
+        , navAccess'     = is _Just <$> maybeAuthId
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      }
+  , do
+      mCurrentRoute <- getCurrentRoute
+
+      activeLang <- selectLanguage appLanguages
+
+      let navChildren = flip map (toList appLanguages) $ \lang -> NavLink
+            { navLabel       = MsgLanguage lang
+            , navRoute       = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ])
+            , navAccess'     = return True
+            , navType        = NavTypeButton
+              { navMethod = POST
+              , navData   = [(toPathPiece PostLanguage, lang)]
+              }
+            , navQuick'      = mempty
+            , navForceActive = lang == activeLang
+            }
+
+      guard $ length navChildren > 1
+
+      return NavHeaderContainer
+        { navHeaderRole = NavHeaderSecondary
+        , navLabel      = SomeMessage MsgMenuLanguage
+        , navIcon       = IconLanguage
+        , navChildren
+        }
+  , do
+      mCurrentRoute <- getCurrentRoute
+
+      return NavHeader
+        { navHeaderRole = NavHeaderSecondary
+        , navIcon       = IconMenuHelp
+        , navLink       = NavLink
+          { navLabel       = MsgMenuHelp
+          , navRoute       = (HelpR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ])
+          , navAccess'     = return True
+          , navType        = NavTypeLink { navModal = True }
+          , navQuick'      = mempty
+          , navForceActive = False
+          }
+        }
+  , return $ NavFooter NavLink
+      { navLabel       = MsgMenuDataProt
+      , navRoute       = LegalR :#: ("data-protection" :: Text)
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+  , return $ NavFooter NavLink
+      { navLabel       = MsgMenuTermsUse
+      , navRoute       = LegalR :#: ("terms-of-use" :: Text)
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+  , return $ NavFooter NavLink
+      { navLabel       = MsgMenuCopyright
+      , navRoute       = LegalR :#: ("copyright" :: Text)
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+  , return $ NavFooter NavLink
+      { navLabel       = MsgMenuImprint
+      , navRoute       = LegalR :#: ("imprint" :: Text)
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+  , return $ NavFooter NavLink
+      { navLabel       = MsgMenuInformation
+      , navRoute       = InfoR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+  , return $ NavFooter NavLink
+      { navLabel       = MsgMenuFaq
+      , navRoute       = FaqR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+  , return $ NavFooter NavLink
+      { navLabel       = MsgMenuGlossary
+      , navRoute       = GlossaryR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+  , return NavHeader
+      { navHeaderRole = NavHeaderPrimary
+      , navIcon       = IconMenuNews
+      , navLink       = NavLink
+        { navLabel       = MsgMenuNews
+        , navRoute       = NewsR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      }
+  , return NavHeader
+      { navHeaderRole = NavHeaderPrimary
+      , navIcon       = IconMenuCourseList
+      , navLink       = NavLink
+        { navLabel       = MsgMenuCourseList
+        , navRoute       = CourseListR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      }
+  , return NavHeader
+      { navHeaderRole = NavHeaderPrimary
+      , navIcon       = IconMenuCorrections
+      , navLink       = NavLink
+        { navLabel       = MsgMenuCorrections
+        , navRoute       = CorrectionsR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      }
+  , return NavHeader
+      { navHeaderRole = NavHeaderPrimary
+      , navIcon       = IconMenuExams
+      , navLink       = NavLink
+        { navLabel       = MsgMenuExamOfficeExams
+        , navRoute       = ExamOfficeR EOExamsR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      }
+  , return NavHeaderContainer
+      { navHeaderRole = NavHeaderPrimary
+      , navLabel      = SomeMessage MsgAdminHeading
+      , navIcon       = IconMenuAdmin
+      , navChildren   =
+          [ NavLink
+              { navLabel       = MsgMenuUsers
+              , navRoute       = UsersR
+              , navAccess'     = return True
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
+          , NavLink
+              { navLabel       = MsgMenuSchoolList
+              , navRoute       = SchoolListR
+              , navAccess'     = return True
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
+          , NavLink
+              { navLabel       = MsgAdminFeaturesHeading
+              , navRoute       = AdminFeaturesR
+              , navAccess'     = return True
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
+          , NavLink
+              { navLabel       = MsgMenuMessageList
+              , navRoute       = MessageListR
+              , navAccess'     = return True
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
+          , NavLink
+              { navLabel       = MsgMenuAdminErrMsg
+              , navRoute       = AdminErrMsgR
+              , navAccess'     = return True
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
+          , NavLink
+              { navLabel       = MsgMenuAdminTokens
+              , navRoute       = AdminTokensR
+              , navAccess'     = return True
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
+          , NavLink
+              { navLabel       = MsgMenuAdminCrontab
+              , navRoute       = AdminCrontabR
+              , navAccess'     = return True
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
+          , NavLink
+              { navLabel       = MsgMenuAdminTest
+              , navRoute       = AdminTestR
+              , navAccess'     = return True
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
+          ]
+      }
+  , return NavHeaderContainer
+      { navHeaderRole = NavHeaderPrimary
+      , navLabel      = SomeMessage (mempty :: Text)
+      , navIcon       = IconMenuExtra
+      , navChildren   =
+          [ NavLink
+              { navLabel       = MsgMenuCourseNew
+              , navRoute       = CourseNewR
+              , navAccess'     = return True
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
+          , NavLink
+              { navLabel       = MsgMenuExternalExamList
+              , navRoute       = EExamListR
+              , navAccess'     = return True
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
+          , NavLink
+              { navLabel       = MsgMenuTermShow
+              , navRoute       = TermShowR
+              , navAccess'     = return True
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
+          , NavLink
+              { navLabel       = MsgMenuAllocationList
+              , navRoute       = AllocationListR
+              , navAccess'     = return True
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
+          , NavLink
+              { navLabel       = MsgInfoLecturerTitle
+              , navRoute       = InfoLecturerR
+              , navAccess'     = hasWriteAccessTo CourseNewR
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
+          ]
+      }
+  ]
+
+pageActions :: ( MonadHandler m
+               , HandlerSite m ~ UniWorX
+               , MonadCatch m
+               , BearerAuthSite UniWorX
+               )
+            => Route UniWorX -> m [Nav]
+pageActions NewsR = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuOpenCourses
+      , navRoute       = (CourseListR, [("courses-openregistration", toPathPiece True)])
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuOpenAllocations
+      , navRoute       = (AllocationListR, [("allocations-active", toPathPiece True)])
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions (CourseR tid ssh csh CShowR) = do
+  materialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh MaterialListR
+  tutorialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CTutorialListR
+  sheetListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh SheetListR
+  examListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CExamListR
+  membersSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CUsersR
+
+  let examListBound :: Num a => a
+      examListBound = 4 -- guaranteed random; chosen by fair dice roll
+  examListExams <- liftHandler . runDBRead $ do
+    examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do
+      E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
+      E.where_ $ course   E.^. CourseTerm      E.==. E.val tid
+           E.&&. course   E.^. CourseSchool    E.==. E.val ssh
+           E.&&. course   E.^. CourseShorthand E.==. E.val csh
+      E.limit $ succ examListBound
+      return $ exam E.^. ExamName
+    return $ do
+      E.Value examn <- examNames
+      return NavLink
+        { navLabel       = examn
+        , navRoute       = CExamR tid ssh csh examn EShowR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = navQuick NavQuickViewFavourite
+        , navForceActive = False
+        }
+  let showExamList = length examListExams <= examListBound
+
+  let
+    navMembers = NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuCourseMembers
+        , navRoute       = CourseR tid ssh csh CUsersR
+        , navAccess' =
+            let courseWhere course = course <$ do
+                  E.where_ $ course E.^. CourseTerm      E.==. E.val tid
+                       E.&&. course E.^. CourseSchool    E.==. E.val ssh
+                       E.&&. course E.^. CourseShorthand E.==. E.val csh
+                hasParticipants = E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
+                  E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
+                  E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
+                  void $ courseWhere course
+                mayRegister = hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
+             in runDBRead $ mayRegister `or2M` hasParticipants
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = navQuick NavQuickViewFavourite
+        , navForceActive = False
+        }
+      , navChildren = membersSecondary
+      }
+  showMembers <- maybeT (return False) $ True <$ navAccess navMembers
+
+  return $
+    [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuMaterialList
+        , navRoute       = CourseR tid ssh csh MaterialListR
+        , navAccess' =
+            let lecturerAccess     = hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR  -- Always show for lecturers to create new material
+                materialAccess mnm = hasReadAccessTo  $ CMaterialR tid ssh csh mnm MShowR -- otherwise show only if the user can see at least one of the contents
+                existsVisible  = do
+                    matNames <- E.select . E.from $ \(course `E.InnerJoin` material) -> do
+                      E.on     $ course   E.^. CourseId   E.==.   material E.^. MaterialCourse
+                      E.where_ $ course   E.^. CourseTerm      E.==. E.val tid
+                          E.&&.  course   E.^. CourseSchool    E.==. E.val ssh
+                          E.&&.  course   E.^. CourseShorthand E.==. E.val csh
+                      return $ material E.^. MaterialName
+                    anyM matNames (materialAccess . E.unValue)
+             in runDBRead $ lecturerAccess `or2M` existsVisible
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = navQuick NavQuickViewFavourite
+        , navForceActive = False
+        }
+      , navChildren = materialListSecondary
+      }
+    , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuSheetList
+        , navRoute       = CourseR tid ssh csh SheetListR
+        , navAccess' =
+            let lecturerAccess  = hasWriteAccessTo $ CourseR tid ssh csh SheetNewR  -- Always show for lecturers to create new sheets
+                sheetAccess shn = hasReadAccessTo  $ CSheetR tid ssh csh shn SShowR -- othwerwise show only if the user can see at least one of the contents
+                existsVisible  = do
+                    sheetNames <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+                      E.on     $ course   E.^. CourseId   E.==.   sheet E.^. SheetCourse
+                      E.where_ $ course   E.^. CourseTerm      E.==. E.val tid
+                          E.&&.  course   E.^. CourseSchool    E.==. E.val ssh
+                          E.&&.  course   E.^. CourseShorthand E.==. E.val csh
+                      return $ sheet E.^. SheetName
+                    anyM sheetNames $ sheetAccess . E.unValue
+             in runDBRead $ lecturerAccess `or2M` existsVisible
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = navQuick NavQuickViewFavourite
+        , navForceActive = False
+        }
+      , navChildren = sheetListSecondary
+      }
+    , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuTutorialList
+        , navRoute       = CourseR tid ssh csh CTutorialListR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = navQuick NavQuickViewFavourite
+        , navForceActive = False
+        }
+      , navChildren = tutorialListSecondary
+      }
+    , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuExamList
+        , navRoute       = CourseR tid ssh csh CExamListR
+        , navAccess' =
+            let lecturerAccess   = hasWriteAccessTo $ CourseR tid ssh csh CExamNewR
+                examAccess examn = hasReadAccessTo  $ CExamR tid ssh csh examn EShowR
+                existsVisible = do
+                  examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do
+                    E.on     $ course   E.^. CourseId E.==. exam E.^. ExamCourse
+                    E.where_ $ course   E.^. CourseTerm      E.==. E.val tid
+                        E.&&.  course   E.^. CourseSchool    E.==. E.val ssh
+                        E.&&.  course   E.^. CourseShorthand E.==. E.val csh
+                    return $ exam E.^. ExamName
+                  anyM examNames $ examAccess . E.unValue
+             in runDBRead $ lecturerAccess `or2M` existsVisible
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = bool (navQuick NavQuickViewFavourite) mempty showExamList
+        , navForceActive = False
+        }
+      , navChildren = examListSecondary ++ guardOnM showExamList examListExams
+      }
+    , navMembers
+    ] ++ guardOnM (not showMembers) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- membersSecondary ] ++
+    [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuCourseCommunication
+        , navRoute       = CourseR tid ssh csh CCommR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = navQuick NavQuickViewFavourite
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+    , NavPageActionSecondary
+      { navLink = NavLink
+        { navLabel       = MsgMenuCourseExamOffice
+        , navRoute       = CourseR tid ssh csh CExamOfficeR
+        , navAccess' = do
+            uid <- requireAuthId
+            runDBRead $ do
+              cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+              E.selectExists $ do
+                (_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid)
+                E.where_ $ E.not_ isForced
+        , navType        = NavTypeLink { navModal = True }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      }
+    , NavPageActionSecondary
+      { navLink = NavLink
+        { navLabel       = MsgMenuCourseEdit
+        , navRoute       = CourseR tid ssh csh CEditR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      }
+    , NavPageActionSecondary
+      { navLink = NavLink
+        { navLabel       = MsgMenuCourseClone
+        , navRoute       = ( CourseNewR
+                           , [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)]
+                           )
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      }
+    , NavPageActionSecondary
+      { navLink = NavLink
+        { navLabel       = MsgMenuCourseDelete
+        , navRoute       = CourseR tid ssh csh CDeleteR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      }
+    ]
+pageActions (ExamOfficeR EOExamsR) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuExamOfficeFields
+      , navRoute       = ExamOfficeR EOFieldsR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuExamOfficeUsers
+      , navRoute       = ExamOfficeR EOUsersR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions SchoolListR = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuSchoolNew
+      , navRoute       = SchoolNewR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions UsersR = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuLecturerInvite
+      , navRoute       = AdminNewFunctionaryInviteR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuUserAdd
+      , navRoute       = AdminUserAddR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions (AdminUserR cID) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuUserNotifications
+      , navRoute       = UserNotificationR cID
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuUserPassword
+      , navRoute       = UserPasswordR cID
+      , navAccess' = do
+          uid <- decrypt cID
+          User{userAuthentication} <- runDBRead $ get404 uid
+          return $ is _AuthPWHash userAuthentication
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions InfoR = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgInfoLecturerTitle
+      , navRoute       = InfoLecturerR
+      , navAccess'     = hasWriteAccessTo CourseNewR
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuLegal
+      , navRoute       = LegalR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuFaq
+      , navRoute       = FaqR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuGlossary
+      , navRoute       = GlossaryR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions VersionR = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgInfoLecturerTitle
+      , navRoute       = InfoLecturerR
+      , navAccess'     = hasWriteAccessTo CourseNewR
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuLegal
+      , navRoute       = LegalR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuFaq
+      , navRoute       = FaqR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuGlossary
+      , navRoute       = GlossaryR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions HealthR = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuInstance
+      , navRoute       = InstanceR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions InstanceR = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuHealth
+      , navRoute       = HealthR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions HelpR = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuFaq
+      , navRoute       = FaqR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgInfoLecturerTitle
+      , navRoute       = InfoLecturerR
+      , navAccess'     = hasWriteAccessTo CourseNewR
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = do
+        (section, navLabel) <-
+          [ ("courses", MsgInfoLecturerCourses)
+          , ("exercises", MsgInfoLecturerExercises)
+          , ("tutorials", MsgInfoLecturerTutorials)
+          , ("exams", MsgInfoLecturerExams)
+          , ("allocations", MsgInfoLecturerAllocations)
+          ] :: [(Text, UniWorXMessage)]
+        return NavLink
+          { navLabel
+          , navRoute       = InfoLecturerR :#: section
+          , navAccess'     = return True
+          , navType        = NavTypeLink { navModal = False }
+          , navQuick'      = mempty
+          , navForceActive = False
+          }
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuGlossary
+      , navRoute       = GlossaryR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions ProfileR = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuProfileData
+      , navRoute       = ProfileDataR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuAuthPreds
+      , navRoute       = AuthPredsR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgCsvOptions
+      , navRoute       = CsvOptionsR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions TermShowR = do
+  participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
+  return
+    [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuTermCreate
+        , navRoute       = TermEditR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+    , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuParticipantsList
+        , navRoute       = ParticipantsListR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = participantsSecondary
+      }
+    ]
+pageActions (AllocationR tid ssh ash AShowR) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuAllocationInfo
+      , navRoute       = InfoAllocationR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuAllocationUsers
+      , navRoute       = AllocationR tid ssh ash AUsersR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuAllocationCompute
+      , navRoute       = AllocationR tid ssh ash AComputeR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions (AllocationR tid ssh ash AUsersR) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuAllocationPriorities
+      , navRoute       = AllocationR tid ssh ash APriosR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuAllocationCompute
+      , navRoute       = AllocationR tid ssh ash AComputeR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions CourseListR = do
+  participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
+  return
+    [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuCourseNew
+        , navRoute       = CourseNewR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+    , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuAllocationList
+        , navRoute       = AllocationListR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+    , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuParticipantsList
+        , navRoute       = ParticipantsListR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = participantsSecondary
+      }
+    ]
+pageActions CourseNewR = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgInfoLecturerTitle
+      , navRoute       = InfoLecturerR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions (CourseR tid ssh csh CCorrectionsR) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuCorrectionsAssign
+      , navRoute       = CourseR tid ssh csh CAssignR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuCorrectionsOwn
+      , navRoute       = ( CorrectionsR
+                         , [ ("corrections-term", toPathPiece tid)
+                           , ("corrections-school", toPathPiece ssh)
+                           , ("corrections-course", toPathPiece csh)
+                           ]
+                         )
+      , navAccess' = do
+          muid <- maybeAuthId
+          case muid of
+            Nothing -> return False
+            (Just uid) -> do
+              runDBRead . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do
+                E.on $ submission E.^. SubmissionSheet E.==. sheet  E.^. SheetId
+                E.on $ sheet      E.^. SheetCourse     E.==. course E.^. CourseId
+                E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
+                  E.&&. course E.^. CourseTerm      E.==. E.val tid
+                  E.&&. course E.^. CourseSchool    E.==. E.val ssh
+                  E.&&. course E.^. CourseShorthand E.==. E.val csh
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = navQuick NavQuickViewPageActionSecondary
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions (CourseR tid ssh csh SheetListR) = do
+  correctionsSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CCorrectionsR
+
+  let
+    navCorrections = NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuSubmissions
+        , navRoute       = CourseR tid ssh csh CCorrectionsR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
+        , navForceActive = False
+        }
+      , navChildren = correctionsSecondary
+      }
+  showCorrections <- maybeT (return False) $ True <$ navAccess navCorrections
+
+  return $
+    [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuSheetCurrent
+        , navRoute       = CourseR tid ssh csh SheetCurrentR
+        , navAccess' =
+            runDBRead . maybeT (return False) $ do
+              void . MaybeT $ sheetCurrent tid ssh csh
+              return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+    , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuSheetOldUnassigned
+        , navRoute       = CourseR tid ssh csh SheetOldUnassignedR
+        , navAccess' =
+            runDBRead . maybeT (return False) $ do
+              void . MaybeT $ sheetOldUnassigned tid ssh csh
+              return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+    , navCorrections
+    ] ++ guardOnM (not showCorrections) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- correctionsSecondary ] ++
+    [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuSheetNew
+        , navRoute       = CourseR tid ssh csh SheetNewR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+    ]
+pageActions (CourseR tid ssh csh CUsersR) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuCourseAddMembers
+      , navRoute       = CourseR tid ssh csh CAddUserR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = navQuick NavQuickViewPageActionSecondary
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuCourseApplications
+      , navRoute       = CourseR tid ssh csh CApplicationsR
+      , navAccess' =
+          let courseWhere course = course <$ do
+                E.where_ $ course E.^. CourseTerm      E.==. E.val tid
+                     E.&&. course E.^. CourseSchool    E.==. E.val ssh
+                     E.&&. course E.^. CourseShorthand E.==. E.val csh
+              existsApplications = E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do
+                E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
+                void $ courseWhere course
+              courseApplications = fmap (any E.unValue) . E.select . E.from $ \course -> do
+                void $ courseWhere course
+                return $ course E.^. CourseApplicationsRequired
+              courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do
+                E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
+                void $ courseWhere course
+           in runDBRead $ courseAllocation `or2M` courseApplications `or2M` existsApplications
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions (CourseR tid ssh csh MaterialListR) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuMaterialNew
+      , navRoute       = CourseR tid ssh csh MaterialNewR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = navQuick NavQuickViewPageActionSecondary
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions (CMaterialR tid ssh csh mnm MShowR) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuMaterialEdit
+      , navRoute       = CMaterialR tid ssh csh mnm MEditR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionSecondary
+    { navLink = NavLink
+      { navLabel       = MsgMenuMaterialDelete
+      , navRoute       = CMaterialR tid ssh csh mnm MDelR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    }
+  ]
+pageActions (CourseR tid ssh csh CTutorialListR) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuTutorialNew
+      , navRoute       = CourseR tid ssh csh CTutorialNewR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = navQuick NavQuickViewPageActionSecondary
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions (CTutorialR tid ssh csh tutn TEditR) = return
+  [ NavPageActionSecondary
+    { navLink = NavLink
+      { navLabel       = MsgMenuTutorialDelete
+      , navRoute       = CTutorialR tid ssh csh tutn TDeleteR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    }
+  ]
+pageActions (CTutorialR tid ssh csh tutn TUsersR) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuTutorialComm
+      , navRoute       = CTutorialR tid ssh csh tutn TCommR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuTutorialEdit
+      , navRoute       = CTutorialR tid ssh csh tutn TEditR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionSecondary
+    { navLink = NavLink
+      { navLabel       = MsgMenuTutorialDelete
+      , navRoute       = CTutorialR tid ssh csh tutn TDeleteR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    }
+  ]
+pageActions (CourseR tid ssh csh CExamListR) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuExamNew
+      , navRoute       = CourseR tid ssh csh CExamNewR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = navQuick NavQuickViewPageActionSecondary
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions (CExamR tid ssh csh examn EShowR) = do
+  usersSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CExamR tid ssh csh examn EUsersR
+
+  return
+    [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuExamEdit
+        , navRoute       = CExamR tid ssh csh examn EEditR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+    , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuExamUsers
+        , navRoute       = CExamR tid ssh csh examn EUsersR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = usersSecondary
+      }
+    , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuExamGrades
+        , navRoute       = CExamR tid ssh csh examn EGradesR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+    , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuExamCorrect
+        , navRoute       = CExamR tid ssh csh examn ECorrectR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+    ]
+pageActions (CExamR tid ssh csh examn ECorrectR) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuExamUsers
+      , navRoute       = CExamR tid ssh csh examn EUsersR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuExamGrades
+      , navRoute       = CExamR tid ssh csh examn EGradesR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionSecondary
+    { navLink = NavLink
+      { navLabel       = MsgMenuExamEdit
+      , navRoute       = CExamR tid ssh csh examn EEditR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    }
+  ]
+pageActions (CExamR tid ssh csh examn EUsersR) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuExamAddMembers
+      , navRoute       = CExamR tid ssh csh examn EAddUserR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = navQuick NavQuickViewPageActionSecondary
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuExamGrades
+      , navRoute       = CExamR tid ssh csh examn EGradesR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuExamCorrect
+      , navRoute       = CExamR tid ssh csh examn ECorrectR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions (CExamR tid ssh csh examn EGradesR) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuExamUsers
+      , navRoute       = CExamR tid ssh csh examn EUsersR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = navQuick NavQuickViewPageActionSecondary
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuExamCorrect
+      , navRoute       = CExamR tid ssh csh examn ECorrectR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions (CSheetR tid ssh csh shn SShowR) = do
+  subsSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CSheetR tid ssh csh shn SSubsR
+  let
+    navSubmissions = NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuSubmissions
+        , navRoute       = CSheetR tid ssh csh shn SSubsR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = subsSecondary
+      }
+  showSubmissions <- maybeT (return False) $ True <$ navAccess navSubmissions
+
+  return $
+    [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuSubmissionOwn
+        , navRoute       = CSheetR tid ssh csh shn SubmissionOwnR
+        , navAccess' =
+            runDBRead . maybeT (return False) $ do
+              uid <- MaybeT $ liftHandler maybeAuthId
+              submissions <- lift $ submissionList tid csh shn uid
+              guard . not $ null submissions
+              return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+    , navSubmissions
+    ] ++ guardOnM (not showSubmissions) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- subsSecondary ] ++
+    [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuSheetPersonalisedFiles
+        , navRoute       = CSheetR tid ssh csh shn SPersonalFilesR
+        , navAccess'     =
+            let onlyPersonalised = fmap (maybe False $ not . E.unValue) . E.selectMaybe . E.from $ \(sheet `E.InnerJoin` course) -> do
+                  E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
+                  E.where_$ sheet E.^. SheetName E.==. E.val shn
+                      E.&&. course E.^. CourseTerm E.==. E.val tid
+                      E.&&. course E.^. CourseSchool E.==. E.val ssh
+                      E.&&. course E.^. CourseShorthand E.==. E.val csh
+                  return $ sheet E.^. SheetAllowNonPersonalisedSubmission
+                hasPersonalised = E.selectExists . E.from $ \(sheet `E.InnerJoin` course `E.InnerJoin` personalisedSheetFile) -> do
+                  E.on $ personalisedSheetFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
+                  E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
+                  E.where_$ sheet E.^. SheetName E.==. E.val shn
+                      E.&&. course E.^. CourseTerm E.==. E.val tid
+                      E.&&. course E.^. CourseSchool E.==. E.val ssh
+                      E.&&. course E.^. CourseShorthand E.==. E.val csh
+             in runDBRead $ or2M onlyPersonalised hasPersonalised
+        , navType        = NavTypeLink { navModal = True }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+    , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuSheetEdit
+        , navRoute       = CSheetR tid ssh csh shn SEditR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+    , NavPageActionSecondary
+      { navLink = NavLink
+        { navLabel       = MsgMenuSheetClone
+        , navRoute       = (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)])
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      }
+    , NavPageActionSecondary
+      { navLink = NavLink
+        { navLabel       = MsgMenuSheetDelete
+        , navRoute       = CSheetR tid ssh csh shn SDelR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      }
+    ]
+pageActions (CSheetR tid ssh csh shn SSubsR) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuSubmissionNew
+      , navRoute       = CSheetR tid ssh csh shn SubmissionNewR
+      , navAccess' =
+          let submissionAccess = hasWriteAccessTo $ CSheetR tid ssh csh shn SSubsR
+              hasNoSubmission = maybeT (return False) $ do
+                uid <- MaybeT $ liftHandler maybeAuthId
+                submissions <- lift $ submissionList tid csh shn uid
+                guard $ null submissions
+                return True
+           in runDBRead $ hasNoSubmission `or2M` submissionAccess
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = navQuick NavQuickViewPageActionSecondary
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuCorrectionsOwn
+      , navRoute       = ( CorrectionsR
+                         , [ ("corrections-term", toPathPiece tid)
+                           , ("corrections-school", toPathPiece ssh)
+                           , ("corrections-course", toPathPiece csh)
+                           , ("corrections-sheet", toPathPiece shn)
+                           ]
+                         )
+      , navAccess'     = (== Authorized) <$> evalAccessCorrector tid ssh csh
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = navQuick NavQuickViewPageActionSecondary
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuCorrectionsAssign
+      , navRoute       = CSheetR tid ssh csh shn SAssignR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = navQuick NavQuickViewPageActionSecondary
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuCorrection
+      , navRoute       = CSubmissionR tid ssh csh shn cid CorrectionR
+      , navAccess'     = hasWriteAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgCorrectorAssignTitle
+      , navRoute       = CSubmissionR tid ssh csh shn cid SubAssignR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionSecondary
+    { navLink = NavLink
+      { navLabel       = MsgMenuSubmissionDelete
+      , navRoute       = CSubmissionR tid ssh csh shn cid SubDelR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    }
+  ]
+pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgCorrectorAssignTitle
+      , navRoute       = CSubmissionR tid ssh csh shn cid SubAssignR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionSecondary
+    { navLink = NavLink
+      { navLabel       = MsgMenuSubmissionDelete
+      , navRoute       = CSubmissionR tid ssh csh shn cid SubDelR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    }
+  ]
+pageActions (CourseR tid ssh csh CApplicationsR) = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuCourseApplicationsFiles
+      , navRoute       = CourseR tid ssh csh CAppsFilesR
+      , navAccess' =
+          let appAccess (E.Value appId) = do
+                cID <- encrypt appId
+                hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
+              appSource = E.selectSource . E.from $ \(course `E.InnerJoin` courseApplication) -> do
+                E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
+                E.where_ $ course E.^. CourseTerm E.==. E.val tid
+                     E.&&. course E.^. CourseSchool E.==. E.val ssh
+                     E.&&. course E.^. CourseShorthand E.==. E.val csh
+                E.where_ . E.exists . E.from $ \courseApplicationFile ->
+                  E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. courseApplication E.^. CourseApplicationId
+                return $ courseApplication E.^. CourseApplicationId
+           in runDBRead . runConduit $ appSource .| anyMC appAccess
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuCourseMembers
+      , navRoute       = CourseR tid ssh csh CUsersR
+      , navAccess' =
+          runDBRead $ do
+            cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+            exists [ CourseParticipantCourse ==. cid ]
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions CorrectionsR = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuCorrectionsDownload
+      , navRoute       = CorrectionsDownloadR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = navQuick NavQuickViewPageActionSecondary
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuCorrectionsUpload
+      , navRoute       = CorrectionsUploadR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = navQuick NavQuickViewPageActionSecondary
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuCorrectionsCreate
+      , navRoute       = CorrectionsCreateR
+      , navAccess'     = runDBRead . maybeT (return False) $ do
+          uid <- MaybeT $ liftHandler maybeAuthId
+          sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+            E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+            let
+              isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_
+                    $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
+                E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
+              isLecturer = E.exists . E.from $ \lecturer -> E.where_
+                    $ lecturer E.^. LecturerUser E.==. E.val uid
+                E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
+            E.where_ $ isCorrector' E.||. isLecturer
+            return $ sheet E.^. SheetSubmissionMode
+          return $ orOf (traverse . _Value . _submissionModeCorrector) sheets
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = navQuick NavQuickViewPageActionSecondary
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuCorrectionsGrade
+      , navRoute       = CorrectionsGradeR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions CorrectionsGradeR = do
+  correctionsSecondary <- pageQuickActions NavQuickViewPageActionSecondary CorrectionsR
+  return
+    [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuCorrections
+        , navRoute       = CorrectionsR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = correctionsSecondary
+      }
+    ]
+pageActions EExamListR = return
+  [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuExternalExamNew
+        , navRoute       = EExamNewR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+  ]
+pageActions (EExamR tid ssh coursen examn EEShowR) = return
+  [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuExternalExamEdit
+        , navRoute       = EExamR tid ssh coursen examn EEEditR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+  , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuExternalExamUsers
+        , navRoute       = EExamR tid ssh coursen examn EEUsersR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+  , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuExternalExamGrades
+        , navRoute       = EExamR tid ssh coursen examn EEGradesR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+  ]
+pageActions (EExamR tid ssh coursen examn EEGradesR) = return
+  [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuExternalExamUsers
+        , navRoute       = EExamR tid ssh coursen examn EEUsersR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+  , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuExternalExamEdit
+        , navRoute       = EExamR tid ssh coursen examn EEEditR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+  ]
+pageActions (EExamR tid ssh coursen examn EEUsersR) = return
+  [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuExternalExamGrades
+        , navRoute       = EExamR tid ssh coursen examn EEGradesR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+  , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuExternalExamEdit
+        , navRoute       = EExamR tid ssh coursen examn EEEditR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+  ]
+pageActions ParticipantsListR = return
+  [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgCsvOptions
+        , navRoute       = CsvOptionsR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = True }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
+
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuParticipantsIntersect
+      , navRoute       = ParticipantsIntersectR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False}
+      , navQuick'      = navQuick NavQuickViewPageActionSecondary
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions _ = return []
+
+submissionList :: ( MonadIO m
+                  , BackendCompatible SqlReadBackend backend
+                  )
+               => TermId -> CourseShorthand -> SheetName -> UserId -> ReaderT backend m [E.Value SubmissionId]
+submissionList tid csh shn uid = withReaderT (projectBackend @SqlReadBackend) . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
+  E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+  E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
+  E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
+
+  E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
+       E.&&. sheet E.^. SheetName E.==. E.val shn
+       E.&&. course E.^. CourseShorthand E.==. E.val csh
+       E.&&. course E.^. CourseTerm E.==. E.val tid
+
+  return $ submission E.^. SubmissionId
+
+
+pageQuickActions :: ( MonadCatch m
+                    , MonadHandler m
+                    , HandlerSite m ~ UniWorX
+                    , BearerAuthSite UniWorX
+                    )
+                 => NavQuickView -> Route UniWorX -> m [NavLink]
+pageQuickActions qView route = do
+  items'' <- pageActions route
+  items' <- catMaybes <$> mapM (runMaybeT . navAccess) items''
+  filterM navLinkAccess $ items' ^.. typesUsing @NavChildren @NavLink . filtered (getAny . ($ qView) . navQuick')
+
+-- | Verify that the currently logged in user is lecturer or corrector for at least one sheet for the given course
+evalAccessCorrector
+  :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX)
+  => TermId -> SchoolId -> CourseShorthand -> m AuthResult
+evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False
diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs
index 658f5cf70..52ca3f87c 100644
--- a/src/Foundation/Routes.hs
+++ b/src/Foundation/Routes.hs
@@ -21,8 +21,8 @@ import Foundation.Routes.Definitions
 -- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules
 --
 -- This function also generates the following type synonyms:
--- type Handler x = HandlerT UniWorX IO x
--- type Widget    = WidgetT  UniWorX IO ()
+-- type Handler x = HandlerFor UniWorX x
+-- type Widget    = WidgetFor  UniWorX ()
 mkYesodData "UniWorX" uniworxRoutes
 
 deriving instance Generic CourseR
diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs
new file mode 100644
index 000000000..765c1b70f
--- /dev/null
+++ b/src/Foundation/SiteLayout.hs
@@ -0,0 +1,569 @@
+{-# LANGUAGE UndecidableInstances #-} -- for `MemcachedKeyFavourites`
+
+module Foundation.SiteLayout
+  ( siteLayout', siteLayout
+  , siteLayoutMsg', siteLayoutMsg
+  , getSystemMessageState
+  ) where
+
+import Import.NoFoundation hiding (embedFile)
+
+import Foundation.Type
+import Foundation.Authorization
+import Foundation.Routes
+import Foundation.Navigation
+import Foundation.I18n
+import Foundation.DB
+
+import Utils.SystemMessage
+import Utils.Form
+import Utils.Course
+import Utils.Metrics
+
+import Handler.Utils.Routes
+import Handler.Utils.Memcached
+
+import qualified Data.Text as Text
+import qualified Data.Set as Set
+import qualified Data.HashMap.Strict as HashMap
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+import qualified Data.Conduit.Combinators as C
+
+import Text.Cassius (cassiusFile)
+import Text.Hamlet (hamletFile)
+import Data.FileEmbed (embedFile)
+
+
+data MemcachedKeyFavourites
+  = MemcachedKeyFavouriteQuickActions CourseId AuthContext (NonEmpty Lang)
+  deriving (Generic, Typeable)
+
+deriving instance Eq AuthContext => Eq MemcachedKeyFavourites
+deriving instance Read AuthContext => Read MemcachedKeyFavourites
+deriving instance Show AuthContext => Show MemcachedKeyFavourites
+deriving instance Hashable AuthContext => Hashable MemcachedKeyFavourites
+deriving instance Binary AuthContext => Binary MemcachedKeyFavourites
+
+data MemcachedLimitKeyFavourites
+  = MemcachedLimitKeyFavourites
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Hashable, Binary)
+
+
+siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
+siteLayoutMsg = siteLayout . i18n
+
+{-# DEPRECATED siteLayoutMsg' "Use siteLayoutMsg" #-}
+siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
+siteLayoutMsg' = siteLayoutMsg
+
+siteLayout :: ( BearerAuthSite UniWorX
+              , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
+              , Button UniWorX ButtonSubmit
+              )
+           => WidgetFor UniWorX () -- ^ `pageHeading`
+           -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
+siteLayout = siteLayout' . Just
+
+siteLayout' :: ( BearerAuthSite UniWorX
+               , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
+               , Button UniWorX ButtonSubmit
+               )
+            => Maybe (WidgetFor UniWorX ()) -- ^ `pageHeading`
+            -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
+siteLayout' overrideHeading widget = do
+  AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings
+
+  isModal <- hasCustomHeader HeaderIsModal
+
+  primaryLanguage <- unsafeHead . Text.splitOn "-" <$> selectLanguage appLanguages
+
+  mcurrentRoute <- getCurrentRoute
+  let currentHandler = classifyHandler <$> mcurrentRoute
+
+  currentApproot' <- siteApproot <$> getYesod <*> (reqWaiRequest <$> getRequest)
+
+  -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
+  let
+    breadcrumbs' mcRoute = do
+      mr <- getMessageRender
+      case mcRoute of
+        Nothing -> return (mr MsgErrorResponseTitleNotFound, [])
+        Just cRoute -> do
+          (title, next) <- breadcrumb cRoute
+          crumbs <- go [] next
+          return (title, crumbs)
+      where
+        go crumbs  Nothing      = return crumbs
+        go crumbs (Just cRoute) = do
+          hasAccess <- hasReadAccessTo cRoute
+          (title, next) <- breadcrumb cRoute
+          go ((cRoute, title, hasAccess) : crumbs) next
+  (title, parents) <- breadcrumbs' mcurrentRoute
+
+  --         let isParent :: Route UniWorX -> Bool
+  --             isParent r = r == (fst parents)
+
+  isAuth <- isJust <$> maybeAuthId
+  
+  now <- liftIO getCurrentTime
+
+  -- Lookup Favourites & Theme if possible
+  (favourites', maxFavouriteTerms, currentTheme) <- do
+      muid <- maybeAuthPair
+
+      favCourses'' <- runDBRead . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do
+        E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse
+         E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid)
+
+        let isFavourite = E.not_ . E.isNothing $ courseFavourite E.?. CourseFavouriteId
+            isCurrent
+              | Just (CourseR tid ssh csh _) <- mcurrentRoute
+              =       course E.^. CourseTerm E.==. E.val tid
+                E.&&. course E.^. CourseSchool E.==. E.val ssh
+                E.&&. course E.^. CourseShorthand E.==. E.val csh
+              | otherwise
+              = E.false
+            notBlacklist = E.not_ . E.exists . E.from $ \courseNoFavourite ->
+              E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid)
+                   E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId
+            isParticipant = E.exists . E.from $ \participant ->
+              E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
+                   E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid)
+                   E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
+            isLecturer = E.exists . E.from $ \lecturer ->
+              E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
+                   E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid)
+            isCorrector = E.exists . E.from $ \(corrector `E.InnerJoin` sheet) -> do
+              E.on $ corrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
+               E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId
+              E.where_ $ E.just (corrector E.^. SheetCorrectorUser) E.==. E.val (view _1 <$> muid)
+            isTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do
+              E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
+               E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId
+              E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid)
+            isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor
+            courseVisible = courseIsVisible now course Nothing
+
+            reason = E.case_
+              [ E.when_ isCurrent    E.then_ . E.just $ E.val FavouriteCurrent
+              , E.when_ isAssociated E.then_ . E.just $ E.val FavouriteParticipant
+              ] (E.else_ $ courseFavourite E.?. CourseFavouriteReason)
+
+        E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent
+
+        return (course, reason, courseVisible)
+
+      favCourses' <- forM favCourses'' $ \(course@(Entity _ Course{..}), reason, E.Value courseVisible) -> do
+        mayView <- hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CShowR
+        mayEdit <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
+        return (course, reason, courseVisible, mayView, mayEdit)
+
+      let favCourses = favCourses' & filter (\(_, _, _, mayView, _) -> mayView)
+
+      return ( favCourses
+             , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid
+             , maybe userDefaultTheme userTheme $ view _2 <$> muid
+             )
+
+  let favouriteTerms :: [TermIdentifier]
+      favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _, _, _, _) -> Set.singleton $ unTermKey courseTerm) favourites'
+  
+  favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite, courseVisible, mayView, mayEdit)
+      -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
+             favouriteReason = fromMaybe FavouriteCurrent mFavourite
+         in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do
+              ctx <- getAuthContext
+              MsgRenderer mr <- getMsgRenderer
+              langs <- selectLanguages appLanguages <$> languages
+              let cK = MemcachedKeyFavouriteQuickActions cId ctx langs
+              $logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..."
+              items <- memcachedLimitedKeyTimeoutBy
+                MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1
+                (Right <$> appFavouritesQuickActionsCacheTTL)
+                appFavouritesQuickActionsTimeout
+                cK
+                cK
+                . observeFavouritesQuickActionsDuration $ do
+                  $logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..."
+                  items' <- pageQuickActions NavQuickViewFavourite courseRoute
+                  items <- forM items' $ \n@NavLink{navLabel} -> (mr navLabel,) <$> toTextUrl n
+                  $logDebugS "FavouriteQuickActions" $ tshow cK <> " Done."
+                  return items
+              $logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items)
+              return (c, courseRoute, items, favouriteReason, courseVisible, mayView, mayEdit)
+
+  nav'' <- mconcat <$> sequence
+    [ defaultLinks
+    , maybe (return []) pageActions mcurrentRoute
+    ]
+  nav' <- catMaybes <$> mapM (runMaybeT . navAccess) nav''
+  nav <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse toTextUrl (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> toTextUrl nc) (n ^. _navChildren)
+
+  mmsgs <- if
+    | isModal -> return mempty
+    | otherwise -> do
+        applySystemMessages
+        authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags
+        forM_ authTagPivots $
+          \authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute]))
+        getMessages
+
+  -- (langFormView, langFormEnctype) <- generateFormPost $ identifyForm FIDLanguage langForm
+  -- let langFormView' = wrapForm langFormView def
+  --       { formAction = Just $ SomeRoute LangR
+  --       , formSubmit = FormAutoSubmit
+  --       , formEncoding = langFormEnctype
+  --       }
+
+  let highlight :: HasRoute UniWorX url => url -> Bool
+      -- ^ highlight last route in breadcrumbs, favorites taking priority
+      highlight = (highR ==) . Just . urlRoute
+        where crumbs = mcons mcurrentRoute $ view _1 <$> reverse parents
+              navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to urlRoute) nav
+              highR  = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs
+      highlightNav = (||) <$> navForceActive <*> highlight
+      favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool, Bool, Bool)]
+      favouriteTermReason tid favReason' = favourites
+        & filter (\(Course{..}, _, _, favReason, _, _, _) -> unTermKey courseTerm == tid && favReason == favReason')
+        & sortOn (\(Course{..}, _, _, _, _, _, _) -> courseName)
+
+      -- We break up the default layout into two components:
+      -- default-layout is the contents of the body tag, and
+      -- default-layout-wrapper is the entire page. Since the final
+      -- value passed to hamletToRepHtml cannot be a widget, this allows
+      -- you to use normal widget features in default-layout.
+
+      navWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)]) -> WidgetFor UniWorX ()
+      navWidget (n, navIdent, navRoute', navChildren') = case n of
+        NavHeader{ navLink = navLink@NavLink{..}, .. }
+          | NavTypeLink{..} <- navType
+          , navModal
+            -> customModal Modal
+                 { modalTriggerId = Just navIdent
+                 , modalId = Nothing
+                 , modalTrigger = \mroute ident -> case mroute of
+                     Just route -> $(widgetFile "widgets/navbar/item")
+                     Nothing -> error "navWidget with non-link modal"
+                 , modalContent = Left $ SomeRoute navLink
+                 }
+          | NavTypeLink{} <- navType
+            -> let route = navRoute'
+                   ident = navIdent
+                in $(widgetFile "widgets/navbar/item")
+        NavPageActionPrimary{ navLink = navLink@NavLink{..} }
+          -> let pWidget
+                   | NavTypeLink{..} <- navType
+                   , navModal
+                     = customModal Modal
+                         { modalTriggerId = Just navIdent
+                         , modalId = Nothing
+                         , modalTrigger = \mroute ident -> case mroute of
+                             Just route -> $(widgetFile "widgets/pageaction/primary")
+                             Nothing -> error "navWidget with non-link modal"
+                         , modalContent = Left $ SomeRoute navLink
+                         }
+                   | NavTypeLink{} <- navType
+                     = let route = navRoute'
+                           ident = navIdent
+                        in $(widgetFile "widgets/pageaction/primary")
+                   | otherwise
+                     = error "not implemented"
+                 sWidgets = navChildren'
+                   & map (\(l, i, r) -> navWidget (NavPageActionSecondary l, i, Just r, []))
+              in $(widgetFile "widgets/pageaction/primary-wrapper")
+        NavPageActionSecondary{ navLink = navLink@NavLink{..} }
+          | NavTypeLink{..} <- navType
+          , navModal
+            -> customModal Modal
+                 { modalTriggerId = Just navIdent
+                 , modalId = Nothing
+                 , modalTrigger = \mroute ident -> case mroute of
+                     Just route -> $(widgetFile "widgets/pageaction/secondary")
+                     Nothing -> error "navWidget with non-link modal"
+                 , modalContent = Left $ SomeRoute navLink
+                 }
+          | NavTypeLink{} <- navType
+            -> let route = navRoute'
+                   ident = navIdent
+                in $(widgetFile "widgets/pageaction/secondary")
+        NavHeaderContainer{..} -> $(widgetFile "widgets/navbar/container")
+        NavFooter{ navLink = navLink@NavLink{..} }
+          | NavTypeLink{..} <- navType
+          , not navModal
+            -> let route = navRoute'
+                   ident = navIdent
+                in $(widgetFile "widgets/footer/link")
+        _other -> error "not implemented"
+
+      navContainerItemWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)])
+                             -> (NavLink, Text, Text)
+                             -> WidgetFor UniWorX ()
+      navContainerItemWidget (n, _navIdent, _navRoute', _navChildren') (iN@NavLink{..}, iNavIdent, iNavRoute) = case n of
+        NavHeaderContainer{}
+          | NavTypeLink{..} <- navType
+          , navModal
+            -> customModal Modal
+                 { modalTriggerId = Just iNavIdent
+                 , modalId = Nothing
+                 , modalTrigger = \mroute ident -> case mroute of
+                     Just route -> $(widgetFile "widgets/navbar/navbar-container-item--link")
+                     Nothing -> error "navWidget with non-link modal"
+                 , modalContent = Left $ SomeRoute iN
+                 }
+          | NavTypeLink{} <- navType
+            -> let route = iNavRoute
+                   ident = iNavIdent
+                in $(widgetFile "widgets/navbar/navbar-container-item--link")
+          | NavTypeButton{..} <- navType -> do
+              csrfToken <- reqToken <$> getRequest
+              wrapForm $(widgetFile "widgets/navbar/navbar-container-item--button") def
+                { formMethod = navMethod
+                , formSubmit = FormNoSubmit
+                , formAction = Just $ SomeRoute iN
+                }
+        _other -> error "not implemented"
+
+      navbar :: WidgetFor UniWorX ()
+      navbar = do
+        $(widgetFile "widgets/navbar/navbar")
+        forM_ (filter isNavHeaderContainer nav) $ \(_, containerIdent, _, _) ->
+          toWidget $(cassiusFile "templates/widgets/navbar/container-radio.cassius")
+        where isNavHeaderPrimary   = has $ _1 . _navHeaderRole . only NavHeaderPrimary
+              isNavHeaderSecondary = has $ _1 . _navHeaderRole . only NavHeaderSecondary
+      asidenav :: WidgetFor UniWorX ()
+      asidenav = $(widgetFile "widgets/asidenav/asidenav")
+        where
+          logo = preEscapedToMarkup $ decodeUtf8 $(embedFile "assets/lmu/logo.svg")
+      footer :: WidgetFor UniWorX ()
+      footer = $(widgetFile "widgets/footer/footer")
+        where isNavFooter = has $ _1 . _NavFooter
+      alerts :: WidgetFor UniWorX ()
+      alerts = $(widgetFile "widgets/alerts/alerts")
+      contentHeadline :: Maybe (WidgetFor UniWorX ())
+      contentHeadline = overrideHeading <|> (pageHeading =<< mcurrentRoute)
+      breadcrumbsWgt :: WidgetFor UniWorX ()
+      breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs/breadcrumbs")
+      pageaction :: WidgetFor UniWorX ()
+      pageaction = $(widgetFile "widgets/pageaction/pageaction")
+      -- functions to determine if there are page-actions (primary or secondary)
+      hasPageActions, hasSecondaryPageActions, hasPrimaryPageActions :: Bool
+      hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions
+      hasSecondaryPageActions = has (folded . _1 . _NavPageActionSecondary) nav
+      hasPrimaryPageActions   = has (folded . _1 . _NavPageActionPrimary  ) nav
+      hasPrimarySubActions = has (folded . _1 . filtered (is _NavPageActionPrimary) . _navChildren . folded) nav
+      contentRibbon :: Maybe (WidgetFor UniWorX ())
+      contentRibbon = fmap toWidget appRibbon
+
+      isNavHeaderContainer = has $ _1 . _NavHeaderContainer
+      isPageActionPrimary = has $ _1 . _NavPageActionPrimary
+      isPageActionSecondary = has $ _1 . _NavPageActionSecondary
+
+  MsgRenderer mr <- getMsgRenderer
+  let
+    -- See Utils.Frontend.I18n and files in messages/frontend for message definitions
+    frontendI18n = toJSON (mr :: FrontendMessage -> Text)
+  frontendDatetimeLocale <- toJSON <$> selectLanguage frontendDatetimeLocales
+
+  pc <- widgetToPageContent $ do
+      webpackLinks_main StaticR
+      toWidget $(juliusFile "templates/i18n.julius")
+      whenIsJust currentApproot' $ \currentApproot ->
+        toWidget $(juliusFile "templates/approot.julius")
+      whenIsJust mcurrentRoute $ \currentRoute' -> do
+        currentRoute <- toTextUrl currentRoute'
+        toWidget $(juliusFile "templates/current-route.julius")
+      wellKnownHtmlLinks
+
+      $(widgetFile "default-layout")
+  withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
+
+  
+getSystemMessageState :: (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => SystemMessageId -> m UserSystemMessageState
+getSystemMessageState smId = liftHandler $ do
+  muid <- maybeAuthId
+  reqSt <- $cachedHere getSystemMessageStateRequest
+  dbSt <- $cachedHere $ maybe (return mempty) getDBSystemMessageState muid
+  let MergeHashMap smSt = reqSt <> dbSt
+      smSt' = MergeHashMap $ HashMap.filter (/= mempty) smSt
+  when (smSt' /= reqSt) $
+        setRegisteredCookieJson CookieSystemMessageState
+    =<< ifoldMapM (\smId' v -> MergeHashMap <$> (HashMap.singleton <$> encrypt smId' <*> pure v :: HandlerFor UniWorX (HashMap CryptoUUIDSystemMessage _))) smSt'
+
+  return . fromMaybe mempty $ HashMap.lookup smId smSt
+  where
+    getSystemMessageStateRequest =
+          (lookupRegisteredCookiesJson id CookieSystemMessageState :: HandlerFor UniWorX (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState))
+      >>= ifoldMapM (\(cID :: CryptoUUIDSystemMessage) v -> MergeHashMap <$> (maybeT (return mempty) . catchMPlus (Proxy @CryptoIDError) $ HashMap.singleton <$> decrypt cID <*> pure v))
+    getDBSystemMessageState uid = runDBRead . runConduit $ selectSource [ SystemMessageHiddenUser ==. uid ] [] .| C.foldMap foldSt
+      where foldSt (Entity _ SystemMessageHidden{..})
+              = MergeHashMap . HashMap.singleton systemMessageHiddenMessage $ mempty { userSystemMessageHidden = Just systemMessageHiddenTime }
+
+applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), BearerAuthSite UniWorX) => m ()
+applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do
+  lift $ maybeAuthId >>= traverse_ syncSystemMessageHidden
+
+  cRoute <- lift getCurrentRoute
+  guard $ cRoute /= Just NewsR
+
+  lift . runDBRead . runConduit $ selectSource [] [Asc SystemMessageManualPriority] .| C.mapM_ applyMessage
+  where
+    syncSystemMessageHidden :: UserId -> HandlerFor UniWorX ()
+    syncSystemMessageHidden uid = runDB . withReaderT projectBackend $ do
+      smSt <- lookupRegisteredCookiesJson id CookieSystemMessageState :: SqlPersistT (HandlerFor UniWorX) (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState)
+      iforM_ smSt $ \cID UserSystemMessageState{..} -> do
+        smId <- decrypt cID
+        whenIsJust userSystemMessageHidden $ \systemMessageHiddenTime -> void $
+          upsert SystemMessageHidden
+            { systemMessageHiddenMessage = smId
+            , systemMessageHiddenUser = uid
+            , systemMessageHiddenTime
+            }
+            [ SystemMessageHiddenTime =. systemMessageHiddenTime ]
+
+        when (maybe False (maybe (const True) (<=) userSystemMessageHidden) userSystemMessageUnhidden) $ do
+          deleteBy $ UniqueSystemMessageHidden uid smId
+
+        modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm)
+          -> fmap MergeHashMap . assertM' (/= mempty) $
+               HashMap.update (\smSt' -> assertM' (/= mempty) $ smSt' { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = Nothing }) cID hm
+
+    applyMessage :: Entity SystemMessage -> ReaderT SqlReadBackend (HandlerFor UniWorX) ()
+    applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do
+      guard $ not systemMessageNewsOnly
+
+      cID <- encrypt smId
+      void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False
+
+      now <- liftIO getCurrentTime
+      guard $ NTop systemMessageFrom <= NTop (Just now)
+      guard $ NTop (Just now) < NTop systemMessageTo
+
+      UserSystemMessageState{..} <- lift $ getSystemMessageState smId
+      guard $ userSystemMessageShown <= Just systemMessageLastChanged
+      guard $ userSystemMessageHidden <= Just systemMessageLastUnhide
+
+      (_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId
+      let
+        (summary, content) = case smTrans of
+          Nothing -> (systemMessageSummary, systemMessageContent)
+          Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
+      case summary of
+        Just s ->
+          addMessageWidget systemMessageSeverity $ msgModal (toWidget s) (Left . SomeRoute $ MessageR cID)
+        Nothing -> addMessage systemMessageSeverity content
+
+      tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $
+        HashMap.singleton cID mempty{ userSystemMessageShown = Just now }
+
+
+-- FIXME: Move headings into their respective handlers
+  
+-- | Method for specifying page heading for handlers that call defaultLayout
+--
+-- All handlers whose code is under our control should use
+-- `siteLayout` instead; `pageHeading` is only a fallback solution for
+-- e.g. subsites like `AuthR`
+pageHeading :: ( YesodPersist UniWorX
+               , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
+               ) => Route UniWorX -> Maybe Widget
+pageHeading (AuthR _)
+  = Just $ i18n MsgLoginHeading
+pageHeading NewsR
+  = Just $ i18n MsgNewsHeading
+pageHeading UsersR
+  = Just $ i18n MsgUsers
+pageHeading (AdminUserR _)
+  = Just $ i18n MsgAdminUserHeading
+pageHeading AdminTestR
+  = Just [whamlet|Internal Code Demonstration Page|]
+pageHeading AdminErrMsgR
+  = Just $ i18n MsgErrMsgHeading
+
+pageHeading InfoR
+  = Just $ i18n MsgInfoHeading
+pageHeading LegalR
+  = Just $ i18n MsgLegalHeading
+pageHeading VersionR
+  = Just $ i18n MsgVersionHeading
+
+pageHeading HelpR
+  = Just $ i18n MsgHelpRequest
+
+pageHeading ProfileR
+  = Just $ i18n MsgProfileHeading
+pageHeading ProfileDataR
+  = Just $ i18n MsgProfileDataHeading
+
+pageHeading TermShowR
+  = Just $ i18n MsgTermsHeading
+pageHeading TermCurrentR
+  = Just $ i18n MsgTermCurrent
+pageHeading TermEditR
+  = Just $ i18n MsgTermEditHeading
+pageHeading (TermEditExistR tid)
+  = Just $ i18n $ MsgTermEditTid tid
+pageHeading (TermCourseListR tid)
+  = Just . i18n . MsgTermCourseListHeading $ tid
+pageHeading (TermSchoolCourseListR tid ssh)
+  = Just $ do
+      School{schoolName=school} <- handlerToWidget . runDB . withReaderT (projectBackend @SqlBackend) $ get404 ssh
+      i18n $ MsgTermSchoolCourseListHeading tid school
+
+pageHeading CourseListR
+  = Just $ i18n MsgCourseListTitle
+pageHeading CourseNewR
+  = Just $ i18n MsgCourseNewHeading
+pageHeading (CourseR tid ssh csh CShowR)
+  = Just $ do
+    Entity _ Course{..} <- handlerToWidget . runDB . withReaderT (projectBackend @SqlBackend) . getBy404 $ TermSchoolCourseShort tid ssh csh
+    toWidget courseName
+--          (CourseR tid csh CRegisterR) -- just for POST
+pageHeading (CourseR tid ssh csh CEditR)
+  = Just $ i18n $ MsgCourseEditHeading tid ssh csh
+pageHeading (CourseR tid ssh csh CCorrectionsR)
+  = Just $ i18n $ MsgSubmissionsCourse tid ssh csh
+pageHeading (CourseR tid ssh csh SheetListR)
+  = Just $ i18n $ MsgSheetList tid ssh csh
+pageHeading (CourseR tid ssh csh SheetNewR)
+  = Just $ i18n $ MsgSheetNewHeading tid ssh csh
+pageHeading (CSheetR tid ssh csh shn SShowR)
+  = Just $ i18n $ MsgSheetTitle tid ssh csh shn
+  -- = Just $ i18n $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity
+pageHeading (CSheetR tid ssh csh shn SEditR)
+  = Just $ i18n $ MsgSheetEditHead tid ssh csh shn
+pageHeading (CSheetR tid ssh csh shn SDelR)
+  = Just $ i18n $ MsgSheetDelHead tid ssh csh shn
+pageHeading (CSheetR _tid _ssh _csh shn SSubsR)
+  = Just $ i18n $ MsgSubmissionsSheet shn
+pageHeading (CSheetR tid ssh csh shn SubmissionNewR)
+  = Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn
+pageHeading (CSheetR tid ssh csh shn SubmissionOwnR)
+  = Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn
+pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one!
+  = Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn
+--          (CSubmissionR tid csh shn cid SubArchiveR) -- just a download
+pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR)
+  = Just $ i18n $ MsgCorrectionHead tid ssh csh shn cid
+--          (CSubmissionR tid csh shn cid SubDownloadR) -- just a download
+--          (CSheetR tid ssh csh shn SFileR) -- just for Downloads
+
+pageHeading CorrectionsR
+  = Just $ i18n MsgCorrectionsTitle
+pageHeading CorrectionsUploadR
+  = Just $ i18n MsgCorrUpload
+pageHeading CorrectionsCreateR
+  = Just $ i18n MsgCorrCreate
+pageHeading CorrectionsGradeR
+  = Just $ i18n MsgCorrGrade
+pageHeading (MessageR _)
+  = Just $ i18n MsgSystemMessageHeading
+pageHeading MessageListR
+  = Just $ i18n MsgSystemMessageListHeading
+
+-- TODO: add headings for more single course- and single term-pages
+pageHeading _
+  = Nothing
diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs
index ee96ec211..5595127e8 100644
--- a/src/Foundation/Type.hs
+++ b/src/Foundation/Type.hs
@@ -7,6 +7,7 @@ module Foundation.Type
   , _SessionStorageMemcachedSql, _SessionStorageAcid
   , SMTPPool
   , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport
+  , DB, Form, MsgRenderer, MailM
   ) where
 
 import Import.NoFoundation
@@ -74,3 +75,9 @@ instance HasCookieSettings RegisteredCookie UniWorX where
 
 instance (MonadHandler m, HandlerSite m ~ UniWorX) => ReadLogSettings m where
   readLogSettings = liftIO . readTVarIO =<< getsYesod (view _appLogSettings)
+
+  
+type DB = YesodDB UniWorX
+type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, WidgetFor UniWorX ())
+type MsgRenderer = MsgRendererS UniWorX -- see Utils
+type MailM a = MailT (HandlerFor UniWorX) a
diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
new file mode 100644
index 000000000..66941c9f6
--- /dev/null
+++ b/src/Foundation/Yesod/Auth.hs
@@ -0,0 +1,498 @@
+module Foundation.Yesod.Auth
+  ( authenticate
+  , upsertCampusUser
+  , CampusUserConversionException(..)
+  , campusUserFailoverMode, updateUserLanguage
+  ) where
+
+import Import.NoFoundation hiding (authenticate)
+
+import Foundation.Type
+import Foundation.Types
+import Foundation.I18n
+
+import Handler.Utils.Profile
+import Handler.Utils.StudyFeatures
+import Handler.Utils.SchoolLdap
+
+import Yesod.Auth.Message
+import Auth.LDAP
+
+import qualified Data.CaseInsensitive as CI
+import qualified Control.Monad.Catch as C (Handler(..))
+import qualified Data.List.NonEmpty as NonEmpty
+import qualified Ldap.Client as Ldap
+import qualified Data.Text.Encoding as Text
+import qualified Data.ByteString as ByteString
+import qualified Data.Set as Set
+import qualified Data.Conduit.Combinators as C
+
+import qualified Data.List as List ((\\))
+  
+import qualified Data.UUID as UUID
+import Data.ByteArray (convert)
+import Crypto.Hash (SHAKE128)
+import qualified Data.Binary as Binary
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+import Control.Monad.Writer.Class (MonadWriter(..))
+import Crypto.Hash.Conduit (sinkHash)
+
+
+authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
+                , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
+                , YesodAuth UniWorX, UserId ~ AuthId UniWorX
+                )
+             => Creds UniWorX -> m (AuthenticationResult UniWorX)
+authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
+  now <- liftIO getCurrentTime
+
+  let
+    uAuth = UniqueAuthentication $ CI.mk credsIdent
+    upsertMode = creds ^? _upsertCampusUserMode
+
+    isDummy = is (_Just . _UpsertCampusUserDummy) upsertMode
+    isOther = is (_Just . _UpsertCampusUserOther) upsertMode
+
+    excRecovery res
+      | isDummy || isOther
+      = do
+          case res of
+            UserError   err -> addMessageI Error   err
+            ServerError err -> addMessage  Error $ toHtml err
+            _other          -> return ()
+          acceptExisting
+      | otherwise
+      = return res
+
+    excHandlers =
+      [ C.Handler $ \case
+          CampusUserNoResult -> do
+            $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
+            excRecovery . UserError $ IdentifierNotFound credsIdent
+          CampusUserAmbiguous -> do
+            $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
+            excRecovery . UserError $ IdentifierNotFound credsIdent
+          err -> do
+            $logErrorS "LDAP" $ tshow err
+            mr <- getMessageRender
+            excRecovery . ServerError $ mr MsgInternalLdapError
+      , C.Handler $ \(cExc :: CampusUserConversionException) -> do
+          $logErrorS "LDAP" $ tshow cExc
+          mr <- getMessageRender
+          excRecovery . ServerError $ mr cExc
+      ]
+
+    acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX)
+    acceptExisting = do
+      res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
+      case res of
+        Authenticated uid
+          -> associateUserSchoolsByTerms uid
+        _other
+          -> return ()
+      case res of
+        Authenticated uid
+          | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
+        _other -> return res
+
+  $logDebugS "auth" $ tshow Creds{..}
+  UniWorX{..} <- getYesod
+
+  flip catches excHandlers $ case appLdapPool of
+    Just ldapPool
+      | Just upsertMode' <- upsertMode -> do
+          ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
+          $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
+          Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData
+    _other
+      -> acceptExisting
+
+  
+data CampusUserConversionException
+  = CampusUserInvalidIdent
+  | CampusUserInvalidEmail
+  | CampusUserInvalidDisplayName
+  | CampusUserInvalidGivenName
+  | CampusUserInvalidSurname
+  | CampusUserInvalidTitle
+  | CampusUserInvalidMatriculation
+  | CampusUserInvalidSex
+  | CampusUserInvalidFeaturesOfStudy Text
+  | CampusUserInvalidAssociatedSchools Text
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Exception)
+
+_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode
+_upsertCampusUserMode mMode cs@Creds{..}
+  | credsPlugin == "dummy"    = setMode <$> mMode (UpsertCampusUserDummy $ CI.mk credsIdent)
+  | credsPlugin `elem` others = setMode <$> mMode (UpsertCampusUserOther $ CI.mk credsIdent)
+  | otherwise                 = setMode <$> mMode  UpsertCampusUser
+  where
+    setMode UpsertCampusUser
+      = cs{ credsPlugin = "LDAP" }
+    setMode (UpsertCampusUserDummy ident)
+      = cs{ credsPlugin = "dummy", credsIdent = CI.original ident }
+    setMode (UpsertCampusUserOther ident)
+      = cs{ credsPlugin = bool (NonEmpty.head others) credsPlugin (credsPlugin `elem` others), credsIdent = CI.original ident }
+
+    others = "PWHash" :| []
+
+upsertCampusUser :: forall m.
+                    ( MonadHandler m, HandlerSite m ~ UniWorX
+                    , MonadThrow m
+                    )
+                 => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
+upsertCampusUser plugin ldapData = do
+  now <- liftIO getCurrentTime
+  UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
+
+  let
+    userIdent''         = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ]
+    userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ]
+    userEmail'          = fold $ do
+      k' <- toList ldapUserEmail
+      (k, v) <- ldapData
+      guard $ k' == k
+      return v
+    userDisplayName''   = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName   ]
+    userFirstName'      = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName     ]
+    userSurname'        = fold [ v | (k, v) <- ldapData, k == ldapUserSurname       ]
+    userTitle'          = fold [ v | (k, v) <- ldapData, k == ldapUserTitle         ]
+    userSex'            = fold [ v | (k, v) <- ldapData, k == ldapSex               ]
+
+    userAuthentication
+      | is _UpsertCampusUserOther plugin
+      = error "PWHash should only work for users that are already known"
+      | otherwise = AuthLDAP
+    userLastAuthentication = now <$ guard (isn't _UpsertCampusUserDummy plugin)
+
+  userIdent <- if
+    | [bs] <- userIdent''
+    , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
+    , hasn't _upsertCampusUserIdent plugin || has (_upsertCampusUserIdent . only userIdent') plugin
+      -> return userIdent'
+    | Just userIdent' <- plugin ^? _upsertCampusUserIdent
+      -> return userIdent'
+    | otherwise
+      -> throwM CampusUserInvalidIdent
+  userEmail <- if
+    | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') userEmail'
+      -> return $ CI.mk userEmail
+    | otherwise
+      -> throwM CampusUserInvalidEmail
+  userDisplayName' <- if
+    | [bs] <- userDisplayName''
+    , Right userDisplayName' <- Text.decodeUtf8' bs
+      -> return userDisplayName'
+    | otherwise
+      -> throwM CampusUserInvalidDisplayName
+  userFirstName <- if
+    | [bs] <- userFirstName'
+    , Right userFirstName <- Text.decodeUtf8' bs
+      -> return userFirstName
+    | otherwise
+      -> throwM CampusUserInvalidGivenName
+  userSurname <- if
+    | [bs] <- userSurname'
+    , Right userSurname <- Text.decodeUtf8' bs
+      -> return userSurname
+    | otherwise
+      -> throwM CampusUserInvalidSurname
+  userTitle <- if
+    | all ByteString.null userTitle'
+      -> return Nothing
+    | [bs] <- userTitle'
+    , Right userTitle <- Text.decodeUtf8' bs
+      -> return $ Just userTitle
+    | otherwise
+      -> throwM CampusUserInvalidTitle
+  userMatrikelnummer <- if
+    | [bs] <- userMatrikelnummer'
+    , Right userMatrikelnummer <- Text.decodeUtf8' bs
+      -> return $ Just userMatrikelnummer
+    | [] <- userMatrikelnummer'
+      -> return Nothing
+    | otherwise
+      -> throwM CampusUserInvalidMatriculation
+  userSex <- if
+    | [bs] <- userSex'
+    , Right userSex'' <- Text.decodeUtf8' bs
+    , Just userSex''' <- readMay userSex''
+    , Just userSex <- userSex''' ^? iso5218
+      -> return $ Just userSex
+    | [] <- userSex'
+      -> return   Nothing
+    | otherwise
+      -> throwM CampusUserInvalidSex
+
+  let
+    newUser = User
+      { userMaxFavourites        = userDefaultMaxFavourites
+      , userMaxFavouriteTerms    = userDefaultMaxFavouriteTerms
+      , userTheme                = userDefaultTheme
+      , userDateTimeFormat       = userDefaultDateTimeFormat
+      , userDateFormat           = userDefaultDateFormat
+      , userTimeFormat           = userDefaultTimeFormat
+      , userDownloadFiles        = userDefaultDownloadFiles
+      , userWarningDays          = userDefaultWarningDays
+      , userShowSex              = userDefaultShowSex
+      , userNotificationSettings = def
+      , userLanguages            = Nothing
+      , userCsvOptions           = def
+      , userTokensIssuedAfter    = Nothing
+      , userCreated              = now
+      , userLastLdapSynchronisation = Just now
+      , userDisplayName          = userDisplayName'
+      , userDisplayEmail         = userEmail
+      , ..
+      }
+    userUpdate =  [ UserMatrikelnummer          =. userMatrikelnummer
+                  -- , UserDisplayName             =. userDisplayName
+                  , UserFirstName               =. userFirstName
+                  , UserSurname                 =. userSurname
+                  , UserTitle                   =. userTitle
+                  , UserEmail                   =. userEmail
+                  , UserSex                     =. userSex
+                  , UserLastLdapSynchronisation =. Just now
+                  ] ++
+                  [ UserLastAuthentication =. Just now | isn't _UpsertCampusUserDummy plugin ]
+
+  user@(Entity userId userRec) <- upsertBy (UniqueAuthentication userIdent) newUser userUpdate
+  unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $
+    update userId [ UserDisplayName =. userDisplayName' ]
+
+  let
+    userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
+    userStudyFeatures' = do
+      (k, v) <- ldapData
+      guard $ k == ldapUserStudyFeatures
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      return str
+
+    termNames = nubBy ((==) `on` CI.mk) $ do
+      (k, v) <- ldapData
+      guard $ k == ldapUserFieldName
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      return str
+
+    userSubTermsSemesters = forM userSubTermsSemesters' parseSubTermsSemester
+    userSubTermsSemesters' = do
+      (k, v) <- ldapData
+      guard $ k == ldapUserSubTermsSemester
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      return str
+
+  fs' <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures
+  sts <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userSubTermsSemesters
+
+  let
+    studyTermCandidates = Set.fromList $ do
+      let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs'
+          subTermsKeys = unStudyTermsKey . fst <$> sts
+
+      (,) <$> sfKeys ++ subTermsKeys <*> termNames
+
+  let
+    assimilateSubTerms :: [(StudyTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudyTermsId, Maybe StudyTermsId)) (SqlPersistT m) [StudyFeatures]
+    assimilateSubTerms [] xs = return xs
+    assimilateSubTerms ((subterm, subSemester) : subterms) unusedFeats = do
+      standalone <- lift $ get subterm
+      case standalone of
+        _other
+          | (match : matches, unusedFeats') <- partition
+              (\StudyFeatures{..} -> subterm     == studyFeaturesField
+                                  && subSemester == studyFeaturesSemester
+              ) unusedFeats
+            -> do
+              $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” and matching feature “#{tshow match}”|]
+              (:) match <$> assimilateSubTerms subterms (matches ++ unusedFeats')
+          | any ((== subterm) . studyFeaturesField) unusedFeats
+            -> do
+              $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” due to feature of matching field|]
+              assimilateSubTerms subterms unusedFeats
+        Just StudyTerms{..}
+          | Just defDegree <- studyTermsDefaultDegree
+          , Just defType   <- studyTermsDefaultType
+            -> do
+              $logDebugS "Campus" [st|Applying default for standalone study term “#{tshow subterm}”|]
+              (:) (StudyFeatures userId defDegree subterm Nothing defType subSemester now True) <$> assimilateSubTerms subterms unusedFeats
+        Nothing
+          | [] <- unusedFeats -> do
+              $logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|]
+              tell $ Set.singleton (subterm, Nothing)
+              assimilateSubTerms subterms []
+        _other -> do
+          knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] []
+          let matchingFeatures = case knownParents of
+                []      -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats
+                ps      -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> elem studyFeaturesField ps && studyFeaturesSemester == subSemester) unusedFeats
+          when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} ->
+            tell $ Set.singleton (subterm, Just studyFeaturesField)
+          if
+            | not $ null knownParents -> do
+                $logDebugS "Campus" [st|Applying subterm “#{tshow subterm}” to #{tshow matchingFeatures}|]
+                let setSuperField sf = sf
+                      & _studyFeaturesSuperField %~ (<|> Just (sf ^. _studyFeaturesField))
+                      & _studyFeaturesField .~ subterm
+                (++) (map setSuperField matchingFeatures) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures)
+            | otherwise -> do
+                $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}”|]
+                assimilateSubTerms subterms unusedFeats
+  $logDebugS "Campus" [st|Terms for “#{userIdent}”: #{tshow (sts, fs')}|]
+  (fs, studyFieldParentCandidates) <- runWriterT $ assimilateSubTerms sts fs'
+
+  let
+    studyTermCandidateIncidence
+      = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen
+      . UUID.fromByteString
+      . fromStrict
+      . (convert :: Digest (SHAKE128 128) -> ByteString)
+      . runConduitPure
+      $ C.yieldMany ((toStrict . Binary.encode <$> Set.toList studyTermCandidates) ++ (toStrict . Binary.encode <$> Set.toList studyFieldParentCandidates)) .| sinkHash
+
+  candidatesRecorded <- E.selectExists . E.from $ \(candidate `E.FullOuterJoin` parentCandidate `E.FullOuterJoin` standaloneCandidate) -> do
+    E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence
+    E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. parentCandidate E.?. StudySubTermParentCandidateIncidence
+    E.where_ $ candidate E.?. StudyTermNameCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
+         E.||. parentCandidate E.?. StudySubTermParentCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
+         E.||. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
+
+  unless candidatesRecorded $ do
+    let
+      studyTermCandidates' = do
+        (studyTermNameCandidateKey, studyTermNameCandidateName) <- Set.toList studyTermCandidates
+        let studyTermNameCandidateIncidence = studyTermCandidateIncidence
+        return StudyTermNameCandidate{..}
+    insertMany_ studyTermCandidates'
+
+    let
+      studySubTermParentCandidates' = do
+        (StudyTermsKey' studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates
+        let studySubTermParentCandidateIncidence = studyTermCandidateIncidence
+        return StudySubTermParentCandidate{..}
+    insertMany_ studySubTermParentCandidates'
+
+    let
+      studyTermStandaloneCandidates' = do
+        (StudyTermsKey' studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates
+        let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence
+        return StudyTermStandaloneCandidate{..}
+    insertMany_ studyTermStandaloneCandidates'
+
+  E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
+  forM_ fs $ \f@StudyFeatures{..} -> do
+    insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
+    insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing
+    oldFs <- selectKeysList
+      [ StudyFeaturesUser ==. studyFeaturesUser
+       , StudyFeaturesDegree ==. studyFeaturesDegree
+       , StudyFeaturesField ==. studyFeaturesField
+       , StudyFeaturesType ==. studyFeaturesType
+       , StudyFeaturesSemester ==. studyFeaturesSemester
+       ]
+      []
+    case oldFs of
+      [oldF] -> update oldF
+        [ StudyFeaturesUpdated =. now
+        , StudyFeaturesValid =. True
+        , StudyFeaturesField =. studyFeaturesField
+        , StudyFeaturesSuperField =. studyFeaturesSuperField
+        ]
+      _other -> void $ upsert f
+        [ StudyFeaturesUpdated =. now
+        , StudyFeaturesValid =. True
+        , StudyFeaturesSuperField =. studyFeaturesSuperField
+        ]
+  associateUserSchoolsByTerms userId
+
+  let
+    userAssociatedSchools = concat <$> forM userAssociatedSchools' parseLdapSchools
+    userAssociatedSchools' = do
+      (k, v) <- ldapData
+      guard $ k == ldapUserSchoolAssociation
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      return str
+
+  ss <- either (throwM . CampusUserInvalidAssociatedSchools . tshow) return userAssociatedSchools
+
+  forM_ ss $ \frag -> void . runMaybeT $ do
+    let
+      exactMatch = MaybeT . getBy $ UniqueOrgUnit frag
+      infixMatch = (hoistMaybe . preview _head) <=< (lift . E.select . E.from) $ \schoolLdap -> do
+        E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit
+             E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool)
+        return schoolLdap
+    Entity _ SchoolLdap{..} <- exactMatch <|> infixMatch
+    ssh <- hoistMaybe schoolLdapSchool
+
+    lift . void $ insertUnique UserSchool
+      { userSchoolUser     = userId
+      , userSchoolSchool   = ssh
+      , userSchoolIsOptOut = False
+      }
+
+  forM_ ss $ void . insertUnique . SchoolLdap Nothing
+
+  return user
+  where
+    insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
+
+associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
+associateUserSchoolsByTerms uid = do
+  sfs <- selectList [StudyFeaturesUser ==. uid] []
+
+  forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do
+    schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] []
+    forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) ->
+      void $ insertUnique UserSchool
+        { userSchoolUser     = uid
+        , userSchoolSchool   = schoolTermsSchool
+        , userSchoolIsOptOut = False
+        }
+  
+updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX
+                      , YesodAuth UniWorX
+                      , UserId ~ AuthId UniWorX
+                      )
+                   => Maybe Lang -> SqlPersistT m (Maybe Lang)
+updateUserLanguage (Just lang) = do
+  unless (lang `elem` appLanguages) $
+    invalidArgs ["Unsupported language"]
+
+  muid <- maybeAuthId
+  for_ muid $ \uid -> do
+    langs <- languages
+    update uid [ UserLanguages =. Just (Languages $ lang : nub (filter ((&&) <$> (`elem` appLanguages) <*> (/= lang)) langs)) ]
+  setRegisteredCookie CookieLang lang
+  return $ Just lang
+updateUserLanguage Nothing = runMaybeT $ do
+  uid <- MaybeT maybeAuthId
+  User{..} <- MaybeT $ get uid
+  setLangs <- toList . selectLanguages appLanguages <$> languages
+  highPrioSetLangs <- toList . selectLanguages appLanguages <$> highPrioRequestedLangs
+  let userLanguages' = toList . selectLanguages appLanguages <$> userLanguages ^? _Just . _Wrapped
+  lang <- case (userLanguages', setLangs, highPrioSetLangs) of
+    (_, _, hpl : _)
+      -> lift $ hpl <$ update uid [ UserLanguages =. Just (Languages highPrioSetLangs) ]
+    (Just (l : _), _, _)
+      -> return l
+    (Nothing, l : _, _)
+      -> lift $ l <$ update uid [ UserLanguages =. Just (Languages setLangs) ]
+    (Just [], l : _, _)
+      -> return l
+    (_, [], _)
+      -> mzero
+  setRegisteredCookie CookieLang lang
+  return lang
+
+campusUserFailoverMode :: FailoverMode
+campusUserFailoverMode = FailoverUnlimited
+
+embedRenderMessage ''UniWorX ''CampusUserConversionException id
diff --git a/src/Foundation/Yesod/ErrorHandler.hs b/src/Foundation/Yesod/ErrorHandler.hs
new file mode 100644
index 000000000..025b4098d
--- /dev/null
+++ b/src/Foundation/Yesod/ErrorHandler.hs
@@ -0,0 +1,90 @@
+module Foundation.Yesod.ErrorHandler
+  ( errorHandler
+  ) where
+
+import Import.NoFoundation hiding (errorHandler)
+
+import Utils.Form
+
+import Foundation.Type
+import Foundation.I18n
+import Foundation.Authorization
+import Foundation.SiteLayout
+import Foundation.Routes
+
+import qualified Data.Aeson as JSON
+import qualified Data.Text as Text
+  
+
+errorHandler :: ( MonadSecretBox (HandlerFor UniWorX)
+                , MonadSecretBox (WidgetFor UniWorX)
+                , BearerAuthSite UniWorX
+                , Button UniWorX ButtonSubmit
+                , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
+                )
+             => ErrorResponse -> HandlerFor UniWorX TypedContent
+errorHandler err = do
+  shouldEncrypt <- do
+    canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
+    shouldEncrypt <- getsYesod $ view _appEncryptErrors
+    return $ shouldEncrypt && not canDecrypt
+
+  sessErr <- bool return (_InternalError $ encodedSecretBox SecretBoxShort) shouldEncrypt err
+  setSessionJson SessionError sessErr
+
+  selectRep $ do
+    provideRep $ do
+      mr <- getMessageRender
+      let
+        encrypted :: ToJSON a => a -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
+        encrypted plaintextJson plaintext = do
+          if
+            | shouldEncrypt -> do
+                ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson
+
+                [whamlet|
+                  
    _{MsgErrorResponseEncrypted}
+                  
    +                    #{ciphertext}
+                |]
+            | otherwise -> plaintext
+
+        errPage = case err of
+          NotFound -> [whamlet|
    _{MsgErrorResponseNotFound}|]
+          InternalError err' -> encrypted err' [whamlet|
    #{err'}|]
+          InvalidArgs errs -> [whamlet|
+              
      
+                $forall err' <- errs
+                  
    • #{err'}
+             |]
+          NotAuthenticated -> [whamlet|
      _{MsgErrorResponseNotAuthenticated}|]
+          PermissionDenied err' -> [whamlet|
      #{err'}|]
+          BadMethod method -> [whamlet|
      _{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
+      siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
+        toWidget
+          [cassius|
+            .errMsg
+              white-space: pre-wrap
+              font-family: monospace
+          |]
+        errPage
+    provideRep . fmap PrettyValue $ case err of
+      PermissionDenied err' -> return $ object [ "message" JSON..= err' ]
+      InternalError err'
+        | shouldEncrypt -> do
+            ciphertext <- encodedSecretBox SecretBoxShort err'
+            return $ object [ "message" JSON..= ciphertext
+                            , "encrypted" JSON..= True
+                            ]
+        | otherwise -> return $ object [ "message" JSON..= err' ]
+      InvalidArgs errs -> return $ object [ "messages" JSON..= errs ]
+      _other -> return $ object []
+    provideRep $ case err of
+      PermissionDenied err' -> return err'
+      InternalError err'
+        | shouldEncrypt -> do
+            addHeader "Encrypted-Error-Message" "True"
+            encodedSecretBox SecretBoxPretty err'
+        | otherwise -> return err'
+      InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs
+      _other -> return Text.empty
diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs
new file mode 100644
index 000000000..6ba2b61ca
--- /dev/null
+++ b/src/Foundation/Yesod/Middleware.hs
@@ -0,0 +1,251 @@
+module Foundation.Yesod.Middleware
+  ( yesodMiddleware
+  , updateFavourites
+  ) where
+
+import Import.NoFoundation hiding (yesodMiddleware)
+
+import Foundation.Type
+import Foundation.Routes
+import Foundation.I18n
+import Foundation.Authorization
+
+import Utils.Metrics
+
+import qualified Network.Wai as W
+import qualified Data.Aeson as JSON
+import qualified Data.CaseInsensitive as CI
+  
+import Control.Monad.Reader.Class (MonadReader(..))
+import Control.Monad.Writer.Class (MonadWriter(..))
+
+import Yesod.Core.Types (GHState(..), HandlerData(..), RunHandlerEnv(rheSite, rheChild))
+
+
+yesodMiddleware :: ( BearerAuthSite UniWorX
+                   , BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
+                   , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
+                   )
+                => HandlerFor UniWorX res -> HandlerFor UniWorX res
+yesodMiddleware = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware
+  where
+    dryRunMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+    dryRunMiddleware handler = do
+      dryRun <- isDryRun
+      if | dryRun -> do
+             hData <- ask
+             prevState <- readIORef (handlerState hData)
+             let
+               restoreSession =
+                 modifyIORef (handlerState hData) $
+                   \hst -> hst { ghsSession = ghsSession prevState
+                               , ghsCache = ghsCache prevState
+                               , ghsCacheBy = ghsCacheBy prevState
+                               }
+               site' = (rheSite $ handlerEnv hData) { appMemcached = Nothing }
+               handler' = local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheSite = site', rheChild = site' } }) handler
+
+             addCustomHeader HeaderDryRun $ toPathPiece True
+
+             handler' `finally` restoreSession
+         | otherwise -> handler
+    updateFavouritesMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+    updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
+      route <- MaybeT getCurrentRoute
+      case route of -- update Course Favourites here
+        CourseR tid ssh csh _  -> do
+          void . lift . runDB . runMaybeT $ do
+            guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid ssh csh CShowR) False
+            lift . updateFavourites $ Just (tid, ssh, csh)
+        _other -> return ()
+    normalizeRouteMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+    normalizeRouteMiddleware handler = (*> handler) . runMaybeT $ do
+      route <- MaybeT getCurrentRoute
+      (route', getAny -> changed) <- lift . runDB . runWriterT $ foldM (&) route routeNormalizers
+      when changed $ do
+        $logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|]
+        redirectWith movedPermanently301 route'
+    headerMessagesMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+    headerMessagesMiddleware handler = (handler `finally`) . runMaybeT $ do
+      isModal <- hasCustomHeader HeaderIsModal
+      dbTableShortcircuit <- hasCustomHeader HeaderDBTableShortcircuit
+      massInputShortcircuit <- hasCustomHeader HeaderMassInputShortcircuit
+      $logDebugS "headerMessagesMiddleware" $ tshow (isModal, dbTableShortcircuit, massInputShortcircuit)
+      guard $ or
+        [ isModal
+        , dbTableShortcircuit
+        , massInputShortcircuit
+        ]
+
+      lift . bracketOnError getMessages (mapM_ addMessage') $
+        addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode
+    observeYesodCacheSizeMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+    observeYesodCacheSizeMiddleware handler = handler `finally` observeYesodCacheSize
+    csrfMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+    csrfMiddleware handler = do
+      hasBearer <- is _Just <$> lookupBearerAuth
+
+      if | hasBearer -> local (\HandlerData{..} -> HandlerData{ handlerRequest = handlerRequest { reqToken = Nothing }, .. }) handler
+         | otherwise -> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler
+      where
+        csrfSetCookieMiddleware' handler' = do
+          mcsrf <- reqToken <$> getRequest
+          whenIsJust mcsrf $ setRegisteredCookie CookieXSRFToken
+          handler'
+    storeBearerMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+    storeBearerMiddleware handler = do
+      askBearer >>= \case
+        Just (Jwt bs) -> setSessionBS (toPathPiece SessionBearer) bs
+        Nothing       -> return ()
+
+      handler
+
+updateFavourites :: forall m backend.
+                    ( MonadHandler m, HandlerSite m ~ UniWorX
+                    , BackendCompatible SqlBackend backend
+                    , YesodAuth UniWorX
+                    , UserId ~ AuthId UniWorX
+                    )
+                 => Maybe (TermId, SchoolId, CourseShorthand) -- ^ Insert course into favourites, as appropriate
+                 -> ReaderT backend m ()
+updateFavourites cData = void . withReaderT projectBackend . runMaybeT $ do
+  $logDebugS "updateFavourites" "Updating favourites"
+
+  now <- liftIO getCurrentTime
+  uid <- MaybeT $ liftHandler maybeAuthId
+  mcid  <- (for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh) :: MaybeT (SqlPersistT m) (Maybe CourseId)
+  User{userMaxFavourites} <- MaybeT $ get uid
+
+  -- update Favourites
+  for_ mcid $ \cid ->
+    void . lift $ upsertBy
+      (UniqueCourseFavourite uid cid)
+      (CourseFavourite uid cid FavouriteVisited now)
+      [CourseFavouriteLastVisit =. now]
+  -- prune Favourites to user-defined size
+  oldFavs <- lift $ selectList [CourseFavouriteUser ==. uid] []
+  let deleteFavs = oldFavs
+        & sortOn ((courseFavouriteReason &&& Down . courseFavouriteLastVisit) . entityVal)
+        & drop userMaxFavourites
+        & filter ((<= FavouriteVisited) . courseFavouriteReason . entityVal)
+        & map entityKey
+  unless (null deleteFavs) $
+    lift $ deleteWhere [CourseFavouriteId <-. deleteFavs]
+
+  
+routeNormalizers :: forall m backend.
+                    ( BackendCompatible SqlReadBackend backend
+                    , MonadHandler m, HandlerSite m ~ UniWorX
+                    , BearerAuthSite UniWorX
+                    ) => [Route UniWorX -> WriterT Any (ReaderT backend m) (Route UniWorX)]
+routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .)
+  [ normalizeRender
+  , ncSchool
+  , ncAllocation
+  , ncCourse
+  , ncSheet
+  , ncMaterial
+  , ncTutorial
+  , ncExam
+  , ncExternalExam
+  , verifySubmission
+  , verifyCourseApplication
+  , verifyCourseNews
+  ]
+  where
+    normalizeRender :: Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
+    normalizeRender route = route <$ do
+      YesodRequest{..} <- liftHandler getRequest
+      let original = (W.pathInfo reqWaiRequest, reqGetParams)
+          rendered = renderRoute route
+      if
+        | (isSuffixOf `on` fst) original rendered -> do -- FIXME: this breaks when subsite prefixes are dynamic
+            $logDebugS "normalizeRender" [st|#{tshow rendered} matches #{tshow original}|]
+        | otherwise -> do
+            $logDebugS "normalizeRender" [st|Redirecting because #{tshow rendered} does not match #{tshow original}|]
+            tell $ Any True
+
+    maybeOrig :: (Route UniWorX -> MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX))) (Route UniWorX))
+              -> Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
+    maybeOrig f route = maybeT (return route) $ f route
+
+    caseChanged :: (Eq a, Show a) => CI a -> CI a -> MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX))) ()
+    caseChanged a b
+      | ((/=) `on` CI.original) a b = do
+          $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
+          tell $ Any True
+      | otherwise                   = return ()
+
+    ncSchool = maybeOrig . typesUsing @RouteChildren @SchoolId $ \ssh -> $cachedHereBinary ssh $ do
+      let schoolShort :: SchoolShorthand
+          schoolShort = unSchoolKey ssh
+      Entity ssh' _  <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
+      (caseChanged `on` unSchoolKey) ssh ssh'
+      return ssh'
+    ncAllocation = maybeOrig $ \route -> do
+      AllocationR tid ssh ash _ <- return route
+      Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . lift . getBy $ TermSchoolAllocationShort tid ssh ash
+      caseChanged ash allocationShorthand
+      return $ route & typesUsing @RouteChildren @AllocationShorthand . filtered (== ash) .~ allocationShorthand
+    ncCourse = maybeOrig $ \route -> do
+      CourseR tid ssh csh _ <- return route
+      Entity _ Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
+      caseChanged csh courseShorthand
+      return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand
+    ncSheet = maybeOrig $ \route -> do
+      CSheetR tid ssh csh shn _ <- return route
+      cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
+      Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn
+      caseChanged shn sheetName
+      return $ route & typesUsing @RouteChildren @SheetName . filtered (== shn) .~ sheetName
+    ncMaterial = maybeOrig $ \route -> do
+      CMaterialR tid ssh csh mnm _ <- return route
+      cid <- MaybeT  . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
+      Entity _ Material{..} <- MaybeT . $cachedHereBinary (cid, mnm) . lift . getBy $ UniqueMaterial cid mnm
+      caseChanged mnm materialName
+      return $ route & typesUsing @RouteChildren @MaterialName . filtered (== mnm) .~ materialName
+    ncTutorial = maybeOrig $ \route -> do
+      CTutorialR tid ssh csh tutn _ <- return route
+      cid <- MaybeT  . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
+      Entity _ Tutorial{..} <- MaybeT . $cachedHereBinary (cid, tutn) . lift . getBy $ UniqueTutorial cid tutn
+      caseChanged tutn tutorialName
+      return $ route & typesUsing @RouteChildren @TutorialName . filtered (== tutn) .~ tutorialName
+    ncExam = maybeOrig $ \route -> do
+      CExamR tid ssh csh examn _ <- return route
+      cid <- MaybeT  . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
+      Entity _ Exam{..} <- MaybeT . $cachedHereBinary (cid, examn) . lift . getBy $ UniqueExam cid examn
+      caseChanged examn examName
+      return $ route & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ examName
+    ncExternalExam = maybeOrig $ \route -> do
+      EExamR tid ssh coursen examn _ <- return route
+      Entity _ ExternalExam{..} <- MaybeT . $cachedHereBinary (tid, ssh, coursen, examn) . lift . getBy $ UniqueExternalExam tid ssh coursen examn
+      caseChanged coursen externalExamCourseName
+      caseChanged examn externalExamExamName
+      return $ route
+        & typesUsing @RouteChildren @CourseName . filtered (== coursen) .~ externalExamCourseName
+        & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ externalExamExamName
+    verifySubmission = maybeOrig $ \route -> do
+      CSubmissionR _tid _ssh _csh _shn cID sr <- return route
+      sId <- $cachedHereBinary cID $ decrypt cID
+      Submission{submissionSheet} <- MaybeT . $cachedHereBinary cID . lift $ get sId
+      Sheet{sheetCourse, sheetName} <- MaybeT . $cachedHereBinary submissionSheet . lift $ get submissionSheet
+      Course{courseTerm, courseSchool, courseShorthand} <- MaybeT . $cachedHereBinary sheetCourse . lift $ get sheetCourse
+      let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
+      tell . Any $ route /= newRoute
+      return newRoute
+    verifyCourseApplication = maybeOrig $ \route -> do
+      CApplicationR _tid _ssh _csh cID sr <- return route
+      aId <- decrypt cID
+      CourseApplication{courseApplicationCourse} <- lift . lift $ get404 aId
+      Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseApplicationCourse
+      let newRoute = CApplicationR courseTerm courseSchool courseShorthand cID sr
+      tell . Any $ route /= newRoute
+      return newRoute
+    verifyCourseNews = maybeOrig $ \route -> do
+      CNewsR _tid _ssh _csh cID sr <- return route
+      aId <- decrypt cID
+      CourseNews{courseNewsCourse} <- lift . lift $ get404 aId
+      Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseNewsCourse
+      let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr
+      tell . Any $ route /= newRoute
+      return newRoute
diff --git a/src/Foundation/Yesod/Persist.hs b/src/Foundation/Yesod/Persist.hs
new file mode 100644
index 000000000..98462eda7
--- /dev/null
+++ b/src/Foundation/Yesod/Persist.hs
@@ -0,0 +1,44 @@
+module Foundation.Yesod.Persist
+  ( runDB, getDBRunner
+  , module Foundation.DB
+  ) where
+
+import Import.NoFoundation hiding (runDB, getDBRunner)
+
+import Foundation.Type
+import Foundation.DB
+import Foundation.Authorization
+
+import Database.Persist.Sql (transactionUndo)
+
+
+runDB :: ( YesodPersistBackend UniWorX ~ SqlBackend
+         , BearerAuthSite UniWorX
+         )
+      => YesodDB UniWorX a -> HandlerFor UniWorX a
+runDB action = do
+  -- stack <- liftIO currentCallStack
+  -- $logDebugS "YesodPersist" . unlines $ "runDB" : map pack stack
+  $logDebugS "YesodPersist" "runDB"
+  dryRun <- isDryRun
+  let action'
+        | dryRun = action <* transactionUndo
+        | otherwise = action
+
+  runSqlPoolRetry action' . appConnPool =<< getYesod
+
+getDBRunner :: ( YesodPersistBackend UniWorX ~ SqlBackend
+               , BearerAuthSite UniWorX
+               )
+            => HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ())
+getDBRunner = do
+  (DBRunner{..}, cleanup) <- defaultGetDBRunner appConnPool
+  return . (, cleanup) $ DBRunner
+    (\action -> do
+        dryRun <- isDryRun
+        let action'
+              | dryRun = action <* transactionUndo
+              | otherwise = action
+        $logDebugS "YesodPersist" "runDBRunner"
+        runDBRunner action'
+    )
diff --git a/src/Foundation/Yesod/Session.hs b/src/Foundation/Yesod/Session.hs
new file mode 100644
index 000000000..f8ed7274d
--- /dev/null
+++ b/src/Foundation/Yesod/Session.hs
@@ -0,0 +1,62 @@
+module Foundation.Yesod.Session
+  ( makeSessionBackend
+  ) where
+
+import Import.NoFoundation hiding (makeSessionBackend)
+
+import Foundation.Type
+
+import qualified Web.ServerSession.Core as ServerSession
+import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession
+
+import qualified Network.Wai as W
+import qualified Network.HTTP.Types.Header as W
+import qualified Network.Wai.Middleware.HttpAuth as W (extractBearerAuth)
+
+import Web.Cookie
+
+
+makeSessionBackend :: Yesod UniWorX => UniWorX -> IO (Maybe SessionBackend)
+makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of
+        SessionStorageMemcachedSql sqlStore
+          -> mkBackend . stateSettings =<< ServerSession.createState sqlStore
+        SessionStorageAcid acidStore
+          | appServerSessionAcidFallback
+            -> mkBackend . stateSettings =<< ServerSession.createState acidStore
+        _other
+          -> return Nothing
+      where
+        cfg = JwtSession.ServerSessionJwtConfig
+          { sJwtJwkSet     = appJSONWebKeySet
+          , sJwtStart      = Nothing
+          , sJwtExpiration = appSessionTokenExpiration
+          , sJwtEncoding   = appSessionTokenEncoding
+          , sJwtIssueBy    = appInstanceID
+          , sJwtIssueFor   = appClusterID
+          }
+        mkBackend :: forall sto.
+                   ( ServerSession.SessionData sto ~ Map Text ByteString
+                   , ServerSession.Storage sto
+                   )
+                  => ServerSession.State sto -> IO (Maybe SessionBackend)
+        mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app)
+        stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto
+        stateSettings = ServerSession.setCookieName (toPathPiece CookieSession) . applyServerSessionSettings appServerSessionConfig
+        sameSite
+          | Just sameSiteStrict == cookieSameSite (getCookieSettings app CookieSession)
+          = strictSameSiteSessions
+          | Just sameSiteLax    == cookieSameSite (getCookieSettings app CookieSession)
+          = laxSameSiteSessions
+          | otherwise
+          = id
+        notForBearer :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
+        notForBearer = fmap $ fmap notForBearer'
+          where notForBearer' :: SessionBackend -> SessionBackend
+                notForBearer' (SessionBackend load)
+                  = let load' req
+                          | aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req
+                          , any (is _Just . W.extractBearerAuth) aHdrs
+                          = return (mempty, const $ return [])
+                          | otherwise
+                          = load req
+                     in SessionBackend load'
diff --git a/src/Foundation/Yesod/StaticContent.hs b/src/Foundation/Yesod/StaticContent.hs
new file mode 100644
index 000000000..a60ace7ff
--- /dev/null
+++ b/src/Foundation/Yesod/StaticContent.hs
@@ -0,0 +1,49 @@
+module Foundation.Yesod.StaticContent
+  ( addStaticContent
+  ) where
+
+import Import.NoFoundation hiding (addStaticContent)
+
+import Foundation.Type
+
+import qualified Database.Memcached.Binary.IO as Memcached
+
+import qualified Data.ByteString.Lazy as Lazy
+import qualified Data.ByteString.Base64.URL as Base64 (encodeUnpadded)
+import Data.ByteArray (convert)
+import Crypto.Hash (SHAKE256)
+import Crypto.Hash.Conduit (sinkHash)
+import Data.Bits (Bits(zeroBits))
+
+import qualified Data.Conduit.Combinators as C
+
+
+addStaticContent :: Text
+                 -> Text
+                 -> Lazy.ByteString
+                 -> HandlerFor UniWorX (Maybe (Either Text (Route UniWorX, [(Text, Text)])))
+addStaticContent ext _mime content = do
+  UniWorX{appWidgetMemcached, appSettings'} <- getYesod
+  for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do
+    let expiry = maybe 0 ceiling memcachedExpiry
+        touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
+        add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
+        absoluteLink = unpack widgetMemcachedBaseUrl  fileName
+    catchIf Memcached.isKeyNotFound touch . const $
+      handleIf Memcached.isKeyExists (const $ return ()) add
+    return . Left $ pack absoluteLink
+  where
+    -- Generate a unique filename based on the content itself, this is used
+    -- for deduplication so a collision resistant hash function is required
+    --
+    -- SHA-3 (SHAKE256) seemed to be a future-proof choice
+    --
+    -- Length of hash is 144 bits ~~instead of MD5's 128, so as to avoid
+    -- padding after base64-conversion~~ for backwards compatability
+    fileName = (<.> unpack ext)
+             . unpack
+             . decodeUtf8
+             . Base64.encodeUnpadded
+             . (convert :: Digest (SHAKE256 144) -> ByteString)
+             . runConduitPure
+             $ C.sourceLazy content .| sinkHash
diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index 67b387cd3..18be649b1 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -4,8 +4,6 @@ module Handler.Admin
 
 import Import
 
-import Handler.Utils
-
 import Handler.Admin.Test as Handler.Admin
 import Handler.Admin.ErrorMessage as Handler.Admin
 import Handler.Admin.StudyFeatures as Handler.Admin
diff --git a/src/Handler/Admin/Tokens.hs b/src/Handler/Admin/Tokens.hs
index 70bb3f9ce..826f42f79 100644
--- a/src/Handler/Admin/Tokens.hs
+++ b/src/Handler/Admin/Tokens.hs
@@ -88,7 +88,7 @@ postAdminTokensR = do
 
     fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' btfRoutes btfAddAuth btfExpiresAt btfStartsAt
 
-  siteLayoutMsg' MsgMenuAdminTokens $ do
+  siteLayoutMsg MsgMenuAdminTokens $ do
     setTitleI MsgMenuAdminTokens
 
     let bearerForm = wrapForm bearerView def
diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs
index 2dbfece2a..e0326d9c9 100644
--- a/src/Handler/CryptoIDDispatch.hs
+++ b/src/Handler/CryptoIDDispatch.hs
@@ -5,6 +5,8 @@ module Handler.CryptoIDDispatch
 
 import Import
 
+import Handler.Utils
+  
 import qualified Data.Text as Text
 
 import Yesod.Core.Types (HandlerContents(..))
@@ -45,7 +47,7 @@ instance CryptoRoute UUID UserId where
     (_ :: UserId) <- decrypt cID
     return $ AdminUserR cID
 
-class Dispatch ciphertext (x :: [*]) where
+class Dispatch ciphertext (x :: [Type]) where
   dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX))
 
 instance Dispatch ciphertext '[] where
diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs
index 9c37026ab..f62a9db0e 100644
--- a/src/Handler/Info.hs
+++ b/src/Handler/Info.hs
@@ -23,7 +23,7 @@ getVersionR = selectRep $ do
 -- | Datenschutzerklaerung und Aufbewahrungspflichten, Nutzungsbedingungen, Urheberrecht, Impressum
 getLegalR :: Handler Html
 getLegalR =
-  siteLayoutMsg' MsgMenuLegal $ do
+  siteLayoutMsg MsgMenuLegal $ do
     setTitleI MsgLegalHeading
     let dataProtection = $(i18nWidgetFile "data-protection")
         termsUse       = $(i18nWidgetFile "terms-of-use")
@@ -48,7 +48,7 @@ getInfoR = -- do
 
 getInfoLecturerR :: Handler Html
 getInfoLecturerR =
-  siteLayoutMsg' MsgInfoLecturerTitle $ do
+  siteLayoutMsg MsgInfoLecturerTitle $ do
     setTitleI MsgInfoLecturerTitle
     $(i18nWidgetFile "info-lecturer")
   where
@@ -76,7 +76,7 @@ getInfoLecturerR =
 
 getGlossaryR :: Handler Html
 getGlossaryR =
-  siteLayoutMsg' MsgGlossaryTitle $ do
+  siteLayoutMsg MsgGlossaryTitle $ do
     setTitleI MsgGlossaryTitle
     MsgRenderer mr <- getMsgRenderer
     let
@@ -137,7 +137,7 @@ faqsWidget mLimit route = do
 
 getFaqR :: Handler Html
 getFaqR =
-  siteLayoutMsg' MsgFaqTitle $ do
+  siteLayoutMsg MsgFaqTitle $ do
     setTitleI MsgFaqTitle
 
     fromMaybe mempty . view _1 =<< faqsWidget Nothing Nothing
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index e93498ecb..4699d11c8 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -28,6 +28,8 @@ import qualified Data.CaseInsensitive as CI
 
 import Jobs
 
+import Foundation.Yesod.Auth (updateUserLanguage)
+
 
 data SettingsForm = SettingsForm
       { stgDisplayName          :: UserDisplayName
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 1642e13e6..803fe548b 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -6,8 +6,6 @@ module Handler.Sheet
 
 import Import
 
-import Handler.Utils
-
 
 import Handler.Sheet.CorrectorInvite as Handler.Sheet (getSCorrInviteR, postSCorrInviteR)
 import Handler.Sheet.Delete as Handler.Sheet
diff --git a/src/Handler/Sheet/Current.hs b/src/Handler/Sheet/Current.hs
index 1646785f2..074fa7bd2 100644
--- a/src/Handler/Sheet/Current.hs
+++ b/src/Handler/Sheet/Current.hs
@@ -5,6 +5,7 @@ module Handler.Sheet.Current
 
 import Import
 
+import Handler.Utils
 import Utils.Sheet
 
 
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index d4173fcc7..0c409bdc1 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -25,6 +25,8 @@ import Handler.Submission.Create
 import Handler.Submission.Grade
 import Handler.Submission.Upload
 
+import Handler.Utils
+
 
 import Import
 
diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs
index 95a919e72..b2b99ac45 100644
--- a/src/Handler/Utils.hs
+++ b/src/Handler/Utils.hs
@@ -157,3 +157,21 @@ studyFeaturesWidget featId = do
 
 getShowSex :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
 getShowSex = maybe False (userShowSex . entityVal) <$> maybeAuth
+
+
+-- | Conditional redirect that hides the URL if the user is not authorized for the route
+redirectAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
+redirectAccess url = liftHandler $ do
+  -- must hide URL if not authorized
+  access <- isAuthorized url False
+  case access of
+    Authorized -> redirect url
+    _          -> permissionDeniedI MsgUnauthorizedRedirect
+
+redirectAccessWith :: (MonadHandler m, HandlerSite m ~ UniWorX) => Status -> Route (HandlerSite m) -> m a
+redirectAccessWith status url = liftHandler $ do
+  -- must hide URL if not authorized
+  access <- isAuthorized url False
+  case access of
+    Authorized -> redirectWith status url
+    _          -> permissionDeniedI MsgUnauthorizedRedirect
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 88a8e6070..68f9f68a0 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -15,8 +15,6 @@ import Handler.Utils.Pandoc
 
 import Handler.Utils.DateTime
 
-import Handler.Utils.Widgets
-
 import Handler.Utils.I18n
 
 import Handler.Utils.Files
diff --git a/src/Handler/Utils/Form/MassInput/Liveliness.hs b/src/Handler/Utils/Form/MassInput/Liveliness.hs
index 5e3e4cc75..55022790f 100644
--- a/src/Handler/Utils/Form/MassInput/Liveliness.hs
+++ b/src/Handler/Utils/Form/MassInput/Liveliness.hs
@@ -6,6 +6,7 @@ module Handler.Utils.Form.MassInput.Liveliness
   ) where
 
 import ClassyPrelude
+import Data.Kind (Type)
 
 import Web.PathPieces (PathPiece)
 import Data.Aeson (ToJSON, FromJSON, ToJSONKey, FromJSONKey)
@@ -38,7 +39,7 @@ boxDimension n
 -- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim
 
 class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where
-  type BoxCoord a :: *
+  type BoxCoord a :: Type
   liveCoords :: Prism' (Set (BoxCoord a)) a
   liveCoord :: BoxCoord a -> Prism' Bool a
   liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC))
diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs
index 2a9f90703..e2ffbe14e 100644
--- a/src/Handler/Utils/Invitations.hs
+++ b/src/Handler/Utils/Invitations.hs
@@ -44,19 +44,19 @@ class ( PersistRecordBackend junction (YesodPersistBackend UniWorX)
       , Typeable junction
       ) => IsInvitableJunction junction where
   -- | One side of the junction is always `User`; `InvitationFor junction` is the other
-  type InvitationFor       junction :: *
+  type InvitationFor       junction :: Type
   -- | `junction` without `Key User` and `Key (InvitationFor junction)`
-  data InvitableJunction   junction :: *
+  data InvitableJunction   junction :: Type
 
   -- | `InvitationData` is all data associated with an invitation except for the `UserEmail` and `InvitationFor junction`
   --
   -- Note that this is only the data associated with the invitation; some user input might still be required to construct `InvitableJunction junction`
-  type InvitationData      junction = (dat :: *) | dat -> junction
+  type InvitationData      junction = (dat :: Type) | dat -> junction
   type InvitationData      junction = (InvitationDBData junction, InvitationTokenData junction)
   -- | `InvitationDBData` is the part of `InvitationData` that is stored confidentially in the database
-  data InvitationDBData    junction :: *
+  data InvitationDBData    junction :: Type
   -- | `InvitationTokenData` is the part of `InvitationData` that is stored readably within the token
-  data InvitationTokenData junction :: *
+  data InvitationTokenData junction :: Type
 
   _InvitableJunction :: Iso' junction (UserId, Key (InvitationFor junction), InvitableJunction junction)
 
diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs
index 6160965b4..01d6ca5e8 100644
--- a/src/Handler/Utils/Memcached.hs
+++ b/src/Handler/Utils/Memcached.hs
@@ -30,7 +30,7 @@ import Crypto.Hash.Algorithms (SHAKE256)
 
 import qualified Data.ByteArray as BA
 
-import Language.Haskell.TH
+import Language.Haskell.TH hiding (Type)
 
 import Data.Typeable (typeRep)
 import Type.Reflection (typeOf, TypeRep)
@@ -52,7 +52,7 @@ import qualified Crypto.Saltine.Core.AEAD as AEAD
 import qualified Control.Monad.State.Class as State
 
 
-type Expiry = (Either UTCTime DiffTime)
+type Expiry = Either UTCTime DiffTime
 
 _MemcachedExpiry :: Prism' Expiry Memcached.Expiry
 _MemcachedExpiry = prism' fromExpiry toExpiry
@@ -169,7 +169,7 @@ memcachedSet :: ( MonadHandler m, HandlerSite m ~ UniWorX
              => Maybe Expiry -> a -> m ()
 memcachedSet mExp = memcachedBySet mExp () . MemcachedUnkeyed
 
-memcachedInvalidate :: forall (a :: *) m p.
+memcachedInvalidate :: forall (a :: Type) m p.
                        ( MonadHandler m, HandlerSite m ~ UniWorX
                        , Typeable a
                        )
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index c5c534b1f..ce1767303 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -54,7 +54,6 @@ import Handler.Utils.Form
 import Handler.Utils.Csv
 import Handler.Utils.ContentDisposition
 import Handler.Utils.I18n
-import Handler.Utils.Widgets
 import Utils
 import Utils.Lens
 
@@ -665,12 +664,12 @@ simpleCsvEncodeM fName f = Just DBTCsvEncode
   }
 
 
-class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where
-  data DBParams m x :: *
-  type DBResult m x :: *
-  -- type DBResult' m x :: *
+class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: Type -> Type) (x :: Type) where
+  data DBParams m x :: Type
+  type DBResult m x :: Type
+  -- type DBResult' m x :: Type
 
-  data DBCell m x :: *
+  data DBCell m x :: Type
   dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)
 
   -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index b0aa61ce1..5e35237e6 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -10,6 +10,7 @@ module Handler.Utils.Users
 
 import Import
 import Auth.LDAP (campusUserMatr')
+import Foundation.Yesod.Auth (upsertCampusUser)
 
 import Crypto.Hash (hashlazy)
 
diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs
index bc8f527b6..58da76826 100644
--- a/src/Handler/Utils/Widgets.hs
+++ b/src/Handler/Utils/Widgets.hs
@@ -148,12 +148,6 @@ invDualCoHeat :: ( Real a, Real b, Real c )
 -- ^ Distinguishes @full@, zero is mapped to 2, @optimal@ is mapped to 1, @full@ is mapped to 0
 invDualCoHeat optimal full achieved = 2 - dualCoHeat optimal full achieved
 
-i18n :: forall m msg.
-        ( MonadWidget m
-        , RenderMessage (HandlerSite m) msg
-        ) => msg -> m ()
-i18n = toWidget . (SomeMessage :: msg -> SomeMessage (HandlerSite m))
-
 
 examOccurrenceMappingDescriptionWidget :: ExamOccurrenceRule -> Set ExamOccurrenceMappingDescription -> Widget
 examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets/exam-occurrence-mapping-description")
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index 80b95ad55..76a848624 100644
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@@ -39,6 +39,7 @@ import Utils                  as Import
 import Utils.Frontend.I18n    as Import
 import Utils.DB               as Import
 import Utils.Sql              as Import
+import Utils.Widgets          as Import
 
 import Data.Fixed             as Import
 
@@ -170,6 +171,7 @@ import Network.Minio.Instances as Import ()
 import System.Clock.Instances as Import ()
 import Data.Word.Word24.Instances as Import ()
 import Control.Monad.Trans.Memo.StateCache.Instances as Import (hoistStateCache)
+import Database.Persist.Sql.Types.Instances as Import ()
 
 import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512)
 import Crypto.Random as Import (ChaChaDRG, Seed)
@@ -192,6 +194,8 @@ import GHC.TypeLits as Import (KnownSymbol)
 
 import Data.Word.Word24 as Import
 
+import Data.Kind as Import (Type, Constraint)
+
 
 import Control.Monad.Trans.RWS (RWST)
 
diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs
index f4bdcf021..cd1765f25 100644
--- a/src/Jobs/Handler/SynchroniseLdap.hs
+++ b/src/Jobs/Handler/SynchroniseLdap.hs
@@ -8,6 +8,7 @@ import Import
 import qualified Data.Conduit.List as C
 
 import Auth.LDAP
+import Foundation.Yesod.Auth (CampusUserConversionException, upsertCampusUser)
 
 import Jobs.Queue
 
diff --git a/src/Mail.hs b/src/Mail.hs
index a446040ff..49b743874 100644
--- a/src/Mail.hs
+++ b/src/Mail.hs
@@ -38,6 +38,8 @@ module Mail
 
 import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON)
 
+import Data.Kind (Type)
+
 import Model.Types.Languages
 
 import Network.Mail.Mime hiding (addPart, addAttachment)
@@ -325,7 +327,7 @@ instance Monoid (PrioritisedAlternatives m) where
   mappend = (<>)
 
 class YesodMail site => ToMailPart site a where
-  type MailPartReturn site a :: *
+  type MailPartReturn site a :: Type
   type MailPartReturn site a = ()
   toMailPart :: (MonadMail m, HandlerSite m ~ site) => a -> StateT Part m (MailPartReturn site a)
 
diff --git a/src/Model/Types/File.hs b/src/Model/Types/File.hs
index fbbff7c5b..33bdadbb7 100644
--- a/src/Model/Types/File.hs
+++ b/src/Model/Types/File.hs
@@ -28,7 +28,7 @@ makeLenses_ ''FileReference
 
 
 class HasFileReference record where
-  data FileReferenceResidual record :: *
+  data FileReferenceResidual record :: Type
 
   _FileReference :: Iso' record (FileReference, FileReferenceResidual record)
 
diff --git a/src/Settings.hs b/src/Settings.hs
index e88fbbdc7..56bead944 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -587,3 +587,10 @@ compileTimeAppSettings =
     case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
         Aeson.Error e -> error e
         Aeson.Success settings -> settings
+
+
+getTimeLocale' :: [Lang] -> TimeLocale
+getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")])
+
+appTZ :: TZ
+appTZ = $(includeSystemTZ "Europe/Berlin")
diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs
index ae619dd73..d3d197c19 100644
--- a/src/Settings/Cluster.hs
+++ b/src/Settings/Cluster.hs
@@ -8,6 +8,8 @@ module Settings.Cluster
 import ClassyPrelude.Yesod
 import Web.HttpApiData
 
+import Data.Kind (Type)
+
 import Utils
 import Data.Universe
 
@@ -59,7 +61,7 @@ instance FromHttpApiData ClusterSettingsKey where
 
 
 class (ToJSON (ClusterSettingValue key), FromJSON (ClusterSettingValue key)) => ClusterSetting (key :: ClusterSettingsKey) where
-  type ClusterSettingValue key :: *
+  type ClusterSettingValue key :: Type
   initClusterSetting :: forall m p. MonadIO m => p key -> m (ClusterSettingValue key)
   knownClusterSetting :: forall p. p key -> ClusterSettingsKey
 
diff --git a/src/Utils.hs b/src/Utils.hs
index 2b7fe291b..4d0f216fc 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -183,7 +183,6 @@ instance HasContentType YamlValue where
 toYAML :: ToJSON a => a -> YamlValue
 toYAML = YamlValue . toJSON
 
-
 ---------------------
 -- Text and String --
 ---------------------
diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs
index 8e0337492..08a70924e 100644
--- a/src/Utils/DB.hs
+++ b/src/Utils/DB.hs
@@ -24,51 +24,51 @@ emptyOrIn criterion testSet
 entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
 entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
 
-getJustBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
+getJustBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
           => Unique record -> ReaderT backend m (Entity record)
 getJustBy u = getBy u >>= maybe
   (throwM . PersistForeignConstraintUnmet $ tshow u)
   return
 
-getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
+getKeyBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m)
          => Unique record -> ReaderT backend m (Maybe (Key record))
 getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!
 
-getKeyJustBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
+getKeyJustBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
              => Unique record -> ReaderT backend m (Key record)
 getKeyJustBy u = getKeyBy u >>= maybe
   (throwM . PersistForeignConstraintUnmet $ tshow u)
   return
 
-getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadHandler m)
+getKeyBy404 :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadHandler m)
             => Unique record -> ReaderT backend m (Key record)
 getKeyBy404 u = getKeyBy u >>= maybe notFound return
 
-getEntity404 :: (PersistStoreRead backend, PersistRecordBackend val backend, MonadHandler m)
-             => Key val -> ReaderT backend m (Entity val)
+getEntity404 :: (PersistStoreRead backend, PersistRecordBackend record backend, MonadHandler m)
+             => Key record -> ReaderT backend m (Entity record)
 getEntity404 k = Entity k <$> get404 k
 
-existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
+existsBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m)
          => Unique record -> ReaderT backend m Bool
 existsBy = fmap (is _Just) . getKeyBy
 
-existsBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadHandler m)
+existsBy404 :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadHandler m)
             => Unique record -> ReaderT backend m ()
 existsBy404 = bool notFound (return ()) <=< fmap (is _Just) . getKeyBy
 
-existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadIO m)
+existsKey :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
           => Key record -> ReaderT backend m Bool
 existsKey = exists . pure . (persistIdField ==.)
 
-exists :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadIO m)
+exists :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
        => [Filter record] -> ReaderT backend m Bool
 exists = fmap (not . null) . flip selectKeysList [LimitTo 1]
 
-exists404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadHandler m)
+exists404 :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadHandler m)
           => [Filter record] -> ReaderT backend m ()
 exists404 = bool (return ()) notFound <=< fmap null . flip selectKeysList [LimitTo 1]
 
-existsKey404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadHandler m)
+existsKey404 :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadHandler m)
              => Key record -> ReaderT backend m ()
 existsKey404 = bool notFound (return ()) <=< existsKey
 
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index f3e8461b1..b894c3137 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -5,6 +5,7 @@
 module Utils.Form where
 
 import ClassyPrelude.Yesod hiding (addMessage, addMessageI, cons, Proxy(..), identifyForm, addClass, mreq, areq, wreq)
+import Data.Kind (Type)
 import qualified Yesod.Form.Functions as Yesod
 import Yesod.Core.Instances ()
 import Settings
@@ -275,7 +276,7 @@ identifyForm = identifyForm' id
 -- Buttons (new version ) --
 ----------------------------
 
-data family ButtonClass site :: *
+data family ButtonClass site :: Type
 
 class (PathPiece a, PathPiece (ButtonClass site), RenderMessage site ButtonMessage) => Button site a where
   btnLabel :: a -> WidgetT site IO ()
diff --git a/src/Utils/SystemMessage.hs b/src/Utils/SystemMessage.hs
index 75d016c7e..214cf5b65 100644
--- a/src/Utils/SystemMessage.hs
+++ b/src/Utils/SystemMessage.hs
@@ -6,11 +6,11 @@ import qualified Data.List.NonEmpty as NonEmpty
 import Data.List (findIndex)
 
 
-getSystemMessage :: MonadHandler m
+getSystemMessage :: (MonadHandler m, BackendCompatible SqlReadBackend backend)
                  => NonEmpty Lang -- ^ `appLanguages`
                  -> SystemMessageId
-                 -> ReaderT SqlBackend m (Maybe (SystemMessage, Maybe SystemMessageTranslation))
-getSystemMessage appLanguages smId = runMaybeT $ do
+                 -> ReaderT backend m (Maybe (SystemMessage, Maybe SystemMessageTranslation))
+getSystemMessage appLanguages smId = withReaderT (projectBackend @SqlReadBackend) . runMaybeT $ do
   SystemMessage{..} <- MaybeT $ get smId
   translations <- lift $ selectList [SystemMessageTranslationMessage ==. smId] []
   let
diff --git a/src/Utils/Widgets.hs b/src/Utils/Widgets.hs
new file mode 100644
index 000000000..2732a8470
--- /dev/null
+++ b/src/Utils/Widgets.hs
@@ -0,0 +1,13 @@
+module Utils.Widgets
+  ( i18n
+  ) where
+
+import ClassyPrelude.Yesod
+import Yesod.Core.Types.Instances ()
+
+
+i18n :: forall m msg.
+        ( MonadWidget m
+        , RenderMessage (HandlerSite m) msg
+        ) => msg -> m ()
+i18n = toWidget . (SomeMessage :: msg -> SomeMessage (HandlerSite m))
diff --git a/stack.yaml b/stack.yaml
index b0eae426c..1ad83175a 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -120,6 +120,8 @@ extra-deps:
 
   # - base64-bytestring-1.1.0.0
 
+  - generic-lens-1.2.0.0
+
   - acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
   - bytebuild-0.3.6.0@sha256:aec785c906db5c7ec730754683196eb99a0d48e0deff7d4034c7b58307040b85,2982
   - byteslice-0.2.3.0@sha256:3ebcc77f8ac9fec3ca1a8304e66cfe0a1590c9272b768f2b19637e06de00bf6d,2014
@@ -154,4 +156,5 @@ extra-deps:
   - hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814
 
 resolver: nightly-2020-08-08
+compiler: ghc-8.10.2
 allow-newer: true
diff --git a/stack.yaml.lock b/stack.yaml.lock
index fd5569286..7e6921adc 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -164,6 +164,13 @@ packages:
   original:
     git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git
     commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
+- completed:
+    hackage: generic-lens-1.2.0.0@sha256:b19e7970c93743a46bc3702331512a96d163de4356472f2d51a2945887aefe8c,6524
+    pantry-tree:
+      size: 4315
+      sha256: 9ed161eadfda5b1eb36cfcf077146f7b66db1da69f1041fc720aea287ec021b0
+  original:
+    hackage: generic-lens-1.2.0.0
 - completed:
     hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
     pantry-tree:
diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs
index 13d36e312..2e103bf39 100644
--- a/test/ModelSpec.hs
+++ b/test/ModelSpec.hs
@@ -5,6 +5,8 @@ module ModelSpec where
 
 import TestImport
 
+import Settings (getTimeLocale')
+
 import Model.TypesSpec ()
 
 import qualified Data.CaseInsensitive as CI

From 4478f387170aa72ef0d83b2102d774f3b8faf665 Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Fri, 14 Aug 2020 21:28:37 +0200
Subject: [PATCH 7/8] chore: provide llvm

---
 .gitlab-ci.yml | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index 08d737859..0eaaa8972 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -93,9 +93,11 @@ yesod:build:dev:
   before_script: &haskell
     - rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d
     - install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list
-    - curl https://apt.llvm.org/llvm-snapshot.gpg.key | apt-key add -
+    - apt-key add ${LLVM_APT_KEY}
     - apt update -y
-    - apt install -y --no-install-recommends locales-all openssh-client clang-9 lldb-9 lld-9 clangd-9
+    - apt install -y --no-install-recommends locales-all openssh-client llvm-9
+    - ln -vsf llc-9 /usr/bin/llc
+    - ln -vsf opt-9 /usr/bin/opt
     - install -v -m 0700 -d ~/.ssh
     - install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts
     - install -v -T -m 0400 ${SSH_DEPLOY_KEY} ~/.ssh/deploy && echo "IdentityFile ~/.ssh/deploy" >> ~/.ssh/config; 

From 692eb4d43cc192d48c20f699228eee6ad253d62b Mon Sep 17 00:00:00 2001
From: Gregor Kleen 
Date: Sat, 15 Aug 2020 10:46:25 +0200
Subject: [PATCH 8/8] chore(release): 19.0.0

---
 CHANGELOG.md      | 14 ++++++++++++++
 package-lock.json |  2 +-
 package.json      |  2 +-
 package.yaml      |  2 +-
 4 files changed, 17 insertions(+), 3 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 73b7f7d60..a1f9bec66 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -2,6 +2,20 @@
 
 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.
 
+## [19.0.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.6.0...v19.0.0) (2020-08-15)
+
+
+### refactor
+
+* split foundation & llvm ([c68a01d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c68a01d))
+
+
+### BREAKING CHANGES
+
+* split foundation
+
+
+
 ## [18.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.5.0...v18.6.0) (2020-08-11)
 
 
diff --git a/package-lock.json b/package-lock.json
index 6bfad6734..f3ca829a1 100644
--- a/package-lock.json
+++ b/package-lock.json
@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "18.6.0",
+  "version": "19.0.0",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {
diff --git a/package.json b/package.json
index 725f5f8e4..ada03dbe8 100644
--- a/package.json
+++ b/package.json
@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "18.6.0",
+  "version": "19.0.0",
   "description": "",
   "keywords": [],
   "author": "",
diff --git a/package.yaml b/package.yaml
index 34a56b449..53d3b395e 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,5 +1,5 @@
 name:    uniworx
-version: 18.6.0
+version: 19.0.0
 
 dependencies:
   - base