From 4451ceedf7bde0da7f3bb4c0818b79d7c5df1cbd Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 2 Nov 2020 19:31:25 +0100 Subject: [PATCH] feat(course): warning if re-registration is not possible Fixes #646 BREAKING CHANGE: AccessPredicates now take continuation --- messages/uniworx/de-de-formal.msg | 2 + messages/uniworx/en-eu.msg | 2 + src/Foundation/Authorization.hs | 145 ++++++++++++++------------- src/Foundation/Routes.hs | 20 ++++ src/Handler/Course/Register.hs | 13 ++- src/Handler/Course/Show.hs | 6 +- src/Language/Haskell/TH/Instances.hs | 9 ++ src/Model/Types/Security.hs | 10 ++ src/Utils.hs | 4 + templates/course.hamlet | 8 +- 10 files changed, 143 insertions(+), 76 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index cbaa084ed..7ffc55f97 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -258,6 +258,8 @@ CourseRegistrationFilesNeedReupload: Dateien zur Anmeldung müssen neu hochgelad CourseApplicationDeleteToEdit: Um Ihre Bewerbung zu editieren müssen Sie sie zunächst zurückziehen und sich erneut bewerben. CourseRegistrationDeleteToEdit: Um Ihre Anmeldungsdaten zu editieren müssen Sie sich zunächst ab- und dann erneut anmelden. +CourseDeregistrationNoReRegistration: Wenn Sie sich jetzt vom Kurs abmelden, können Sie sich nicht wieder selbstständig anmelden. + CourseLoginToApply: Um sich zum Kurz zu bewerben müssen Sie sich zunächst in Uni2work anmelden CourseLoginToRegister: Um sich zum Kurs anzumelden müssen Sie zunächst in Uni2work anmelden diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 5ef786e53..62d9fd623 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -258,6 +258,8 @@ CourseRegistrationFilesNeedReupload: Registration files need to be reuploaded ev CourseApplicationDeleteToEdit: You need to withdraw your application and reapply to edit your application. CourseRegistrationDeleteToEdit: You need to deregister and reregister to edit your registration. +CourseDeregistrationNoReRegistration: If you deregister from the course now, you will not be able to re-register yourself. + CourseLoginToApply: You need to login to Uni2work before you can apply for this course. CourseLoginToRegister: Your need to login to Uni2work before you can register for this course. diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 353ed4148..ad088cbe3 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -73,25 +73,27 @@ newtype InvalidAuthTag = InvalidAuthTag Text instance Exception InvalidAuthTag +type AuthTagsEval m = AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult + 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) + | APDB ((forall m. MonadAP m => AuthTagsEval m) -> 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 + evalAccessPred :: AccessPredicate -> (forall m'. MonadAP m' => AuthTagsEval m') -> 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 + evalAccessPred aPred cont 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 + (APDB p) -> runDBRead $ p cont 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 + evalAccessPred aPred cont 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 + (APDB p) -> p cont aid r w orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult @@ -169,7 +171,9 @@ isDryRun = $cachedHere . liftHandler $ orM 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 + let eval :: forall m'. MonadAP m' => AuthTagsEval m' + eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite' + in guardAuthResult <=< fmap fst . runWriterT $ eval dnf mAuthId currentRoute isWrite return False @@ -221,6 +225,8 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val noTokenAuth :: AuthDNF -> AuthDNF noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar + eval :: forall m'. MonadAP m' => AuthTagsEval m' + eval dnf' mAuthId'' route'' isWrite'' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId'' route'' isWrite'' guardMExceptT (not $ Set.null bearerAuthority') $ unauthorizedI MsgUnauthorizedTokenInvalidNoAuthority forM_ bearerAuthority' $ \uid -> do @@ -229,12 +235,12 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val authorityVal <- do dnf <- either throwM return $ routeAuthTags route - fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just uid) route isWrite + fmap fst . runWriterT $ eval (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 + additionalVal <- fmap fst . runWriterT $ eval (noTokenAuth addDNF) mAuthId route isWrite guardExceptT (is _Authorized additionalVal) additionalVal return Authorized @@ -286,7 +292,7 @@ maybeCurrentBearerRestrictions = liftHandler . runMaybeT $ do tagAccessPredicate :: BearerAuthSite UniWorX => AuthTag -> AccessPredicate tagAccessPredicate AuthFree = trueAP -tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of +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 @@ -323,12 +329,12 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] [] guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) return Authorized -tagAccessPredicate AuthSystemExamOffice = APDB $ \mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do +tagAccessPredicate AuthSystemExamOffice = APDB $ \_ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False] guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice return Authorized -tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of +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 @@ -366,7 +372,7 @@ tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice) return Authorized -tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of +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 @@ -382,7 +388,7 @@ tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation] guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation return Authorized -tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route of +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 @@ -398,9 +404,9 @@ tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route o isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation] guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin return Authorized -tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ +tagAccessPredicate AuthToken = APDB $ \_ mAuthId route isWrite -> exceptT return return $ lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe -tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of +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 @@ -421,7 +427,7 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do #else return $ Unauthorized "Route under development" #endif -tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of +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 @@ -460,7 +466,7 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of 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 +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 @@ -488,7 +494,7 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret _ -> do guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) return Authorized -tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of +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 @@ -513,7 +519,7 @@ tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector return Authorized r -> $unsupportedAuthPredicate AuthExamCorrector r -tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do +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 @@ -536,14 +542,14 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return _ -> do guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) return Authorized -tagAccessPredicate AuthTutorControl = APDB $ \_ route _ -> case route of +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 +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 @@ -568,7 +574,7 @@ tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route o return Authorized r -> $unsupportedAuthPredicate AuthSubmissionGroup r -tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthTime = APDB $ \(runTACont -> cont) mAuthId route isWrite -> 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 @@ -668,9 +674,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of 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 + registered <- cont (predDNFSingleton $ PLVariable AuthCourseRegistered) mAuthId route isWrite case mbc of (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo})) | not registered @@ -750,7 +754,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of return Authorized r -> $unsupportedAuthPredicate AuthTime r -tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of +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 @@ -775,16 +779,14 @@ tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of return Authorized r -> $unsupportedAuthPredicate AuthStaffTime r -tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of +tagAccessPredicate AuthAllocationTime = APDB $ \(runTACont -> cont) mAuthId route isWrite -> 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) $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] - _ -> return False + Just (_, Allocation{..}) -> do + registered <- cont (predDNFSingleton $ PLVariable AuthCourseRegistered) mAuthId route isWrite if | not registered , NTop allocationRegisterByCourse >= NTop (Just now) @@ -821,7 +823,7 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of 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 +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 @@ -832,7 +834,7 @@ tagAccessPredicate AuthCourseTime = APDB $ \_mAuthId route _ -> case route of guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime) return Authorized r -> $unsupportedAuthPredicate AuthCourseTime r -tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of +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 @@ -845,7 +847,7 @@ tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) return Authorized r -> $unsupportedAuthPredicate AuthCourseRegistered r -tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of +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 @@ -870,7 +872,7 @@ tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case rout guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) return Authorized r -> $unsupportedAuthPredicate AuthTutorialRegistered r -tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ route _ -> case route of +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 @@ -882,7 +884,7 @@ tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ route _ -> case ro guardMExceptT isOccurrenceRegistration (unauthorizedI MsgUnauthorizedExamOccurrenceRegistration) return Authorized r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistration r -tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \mAuthId route _ -> case route of +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 @@ -923,7 +925,7 @@ tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \mAuthId route _ -> cas guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) return Authorized r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistered r -tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of +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 @@ -964,7 +966,7 @@ tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredAnyExam return Authorized r -> $unsupportedAuthPredicate AuthExamRegistered r -tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of +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 @@ -1017,14 +1019,14 @@ tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult) return Authorized r -> $unsupportedAuthPredicate AuthExamRegistered r -tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case route of +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 +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 @@ -1132,7 +1134,7 @@ 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 -tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of +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 @@ -1153,7 +1155,7 @@ tagAccessPredicate AuthApplicant = 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 -tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of +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 @@ -1173,7 +1175,7 @@ tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of guard $ NTop courseCapacity > NTop (Just registered) return Authorized r -> $unsupportedAuthPredicate AuthCapacity r -tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of +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 @@ -1189,7 +1191,7 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of guard $ not hasOther return Authorized r -> $unsupportedAuthPredicate AuthRegisterGroup r -tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> case route of +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 @@ -1210,20 +1212,20 @@ tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> case route of E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return Authorized r -> $unsupportedAuthPredicate AuthEmpty r -tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of +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 +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 +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 @@ -1238,28 +1240,28 @@ tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \mAuthId route _ -> case 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 +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 +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 +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 +tagAccessPredicate AuthSelf = APDB $ \_ mAuthId route _ -> exceptT return return $ do referencedUser' <- case route of AdminUserR cID -> return $ Left cID AdminUserDeleteR cID -> return $ Left cID @@ -1280,7 +1282,7 @@ tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ | uid == referencedUser -> return Authorized Nothing -> return AuthenticationRequired _other -> unauthorizedI MsgUnauthorizedSelf -tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do +tagAccessPredicate AuthIsLDAP = APDB $ \_ _ route _ -> exceptT return return $ do referencedUser <- case route of AdminUserR cID -> return cID AdminUserDeleteR cID -> return cID @@ -1294,7 +1296,7 @@ tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do User{..} <- MaybeT $ get referencedUser' guard $ userAuthentication == AuthLDAP return Authorized -tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ do +tagAccessPredicate AuthIsPWHash = APDB $ \_ _ route _ -> exceptT return return $ do referencedUser <- case route of AdminUserR cID -> return cID AdminUserDeleteR cID -> return cID @@ -1308,7 +1310,7 @@ tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ d User{..} <- MaybeT $ get referencedUser' guard $ is _AuthPWHash userAuthentication return Authorized -tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of +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 @@ -1329,6 +1331,11 @@ tagAccessPredicate AuthWrite = APPure $ \_ _ isWrite -> do MsgRenderer mr <- ask return $ bool (Unauthorized $ mr MsgUnauthorized) Authorized isWrite +runTACont :: forall m. MonadAP m + => (forall m'. MonadAP m' => AuthTagsEval m') + -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m Bool +runTACont cont dnf mAuthId route isWrite = is _Authorized . fst <$> runWriterT (cont dnf mAuthId route isWrite) + authTagSpecificity :: AuthTag -> AuthTag -> Ordering -- ^ Heuristic for which `AuthTag`s to evaluate first @@ -1370,9 +1377,9 @@ routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partiti | otherwise = Left $ InvalidAuthTag t -evalAuthTags :: forall m. MonadAP m => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult +evalAuthTags :: forall ctx m. (Binary ctx, MonadAP m) => ctx -> AuthTagActive -> (forall m'. MonadAP m' => AuthTagsEval m') -> AuthTagsEval m -- ^ `tell`s disabled predicates, identified as pivots -evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite +evalAuthTags ctx AuthTagActive{..} cont (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite = do mr <- getMsgRenderer let @@ -1382,11 +1389,11 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf 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 + evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (ctx, AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for5 memo (const evalAccessPred') ctx 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' + evalAccessPred (tagAccessPredicate authTag') cont mAuthId' route' isWrite' evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult evalAuthLiteral PLVariable{..} = evalAuthTag plVar @@ -1418,7 +1425,9 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf 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 + let eval :: forall m'. MonadAP m' => AuthTagsEval m' + eval dnf' mAuthId' route' isWrite' = evalAuthTags 'evalAccessFor (AuthTagActive $ const True) eval dnf' mAuthId' route' isWrite' + in fmap fst . runWriterT $ eval 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 @@ -1426,14 +1435,16 @@ 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 + (tagActive :: AuthTagActive) <- 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 + let adjDNF = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) . Just + evalAdj :: forall m'. MonadAP m' => AuthTagsEval m' + evalAdj (adjDNF -> dnf') mAuthId' route' isWrite' = case dnf' of + Nothing -> return Authorized + Just dnf'' -> evalAuthTags ('evalAccessWith, assumptions) tagActive evalAdj dnf'' mAuthId' route' isWrite' + in do + (result, deactivated) <- runWriterT $ evalAdj 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 diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index 52ca3f87c..d2dc89459 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -40,6 +40,26 @@ deriving instance Generic CourseNewsR deriving instance Generic CourseEventR deriving instance Generic (Route UniWorX) +instance Ord (Route Auth) where + compare = compare `on` renderRoute +instance Ord (Route EmbeddedStatic) where + compare = compare `on` renderRoute + +deriving instance Ord CourseR +deriving instance Ord SheetR +deriving instance Ord SubmissionR +deriving instance Ord MaterialR +deriving instance Ord TutorialR +deriving instance Ord ExamR +deriving instance Ord EExamR +deriving instance Ord CourseApplicationR +deriving instance Ord AllocationR +deriving instance Ord SchoolR +deriving instance Ord ExamOfficeR +deriving instance Ord CourseNewsR +deriving instance Ord CourseEventR +deriving instance Ord (Route UniWorX) + data RouteChildren type instance Children RouteChildren a = ChildrenRouteChildren a type family ChildrenRouteChildren a where diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index c4e770f9f..331f94461 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -1,7 +1,7 @@ module Handler.Course.Register ( ButtonCourseRegister(..) , CourseRegisterForm(..) - , courseRegisterForm + , courseRegisterForm, courseMayReRegister , getCRegisterR, postCRegisterR , deregisterParticipant ) where @@ -147,18 +147,29 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do E.||. isCourseExamCorrector muid ata (course E.^. CourseId) ) + mayReRegister <- liftHandler . runDB . courseMayReRegister $ Entity cid Course{..} + when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $ wformMessage =<< messageIconI Warning IconExamRegisterFalse MsgCourseDeregistrationAllocationLog when (is _Just (registration >>= courseParticipantAllocated . entityVal) && courseDeregisterNoShow) $ wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoShow when (isRegistered && not mayViewCourseAfterDeregistration) $ wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationFromInvisibleCourse + unless mayReRegister $ + wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoReRegistration return $ CourseRegisterForm <$ secretRes <*> appTextRes <*> appFilesRes +courseMayReRegister :: Entity Course -> DB Bool +courseMayReRegister (Entity cid Course{..}) = do + registrations <- count [ CourseParticipantState ==. CourseParticipantActive, CourseParticipantCourse ==. cid ] + let capacity = maybe True (>= registrations) courseCapacity + + wouldHaveWriteAccessTo [(AuthCapacity, capacity), (AuthCourseRegistered, False)] $ CourseR courseTerm courseSchool courseShorthand CRegisterR + -- | Workaround for klicking register button without being logged in. -- After log in, the user sees a "get request not supported" error. diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 619c79818..f34d5048f 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -28,7 +28,7 @@ getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId now <- liftIO getCurrentTime - (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen) <- runDB . maybeT notFound $ do + (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister) <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do @@ -106,7 +106,9 @@ getCShowR tid ssh csh = do return $ submissionGroup E.^. SubmissionGroupName let submissionGroup = guardOnM (hasSubmissionGroups && is _Just registration) submissionGroup' - return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen) + mayReRegister <- lift . courseMayReRegister $ Entity cid course + + return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister) let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course mDereg <- traverse (formatTime SelFormatDateTime) mDereg' diff --git a/src/Language/Haskell/TH/Instances.hs b/src/Language/Haskell/TH/Instances.hs index 2a6743c81..f6f8b2bc6 100644 --- a/src/Language/Haskell/TH/Instances.hs +++ b/src/Language/Haskell/TH/Instances.hs @@ -7,6 +7,7 @@ module Language.Haskell.TH.Instances import ClassyPrelude import Language.Haskell.TH +import Language.Haskell.TH.Syntax import Language.Haskell.TH.Lift (deriveLift) import Data.Binary (Binary) @@ -15,6 +16,14 @@ instance Binary Loc deriveLift ''Loc +instance Binary OccName +instance Binary ModName +instance Binary NameSpace +instance Binary PkgName +instance Binary NameFlavour +instance Binary Name + + instance Semigroup (Q [Dec]) where (<>) = liftA2 (<>) diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 02001722f..90fd6bccc 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -211,6 +211,16 @@ dnfAssumeValue var val predDNFFalse :: PredDNF a predDNFFalse = PredDNF Set.empty +predDNFSingleton :: Ord a => PredLiteral a -> PredDNF a +predDNFSingleton = PredDNF . Set.singleton . impureNonNull . Set.singleton + +predDNFAnd, predDNFOr :: Ord a => PredDNF a -> PredDNF a -> PredDNF a +predDNFAnd (PredDNF a) (PredDNF b) = PredDNF . Set.fromList $ do + aConj <- Set.toList a + bConj <- Set.toList b + return . impureNonNull $ toNullable aConj `Set.union` toNullable bConj +predDNFOr (PredDNF a) (PredDNF b) = PredDNF $ a <> b + data UserGroupName = UserGroupMetrics diff --git a/src/Utils.hs b/src/Utils.hs index 3668a5655..79e966c9d 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1162,6 +1162,10 @@ setLastModified lastModified = do safeMethods = [ methodGet, methodHead, methodOptions ] +-- | Adapter for memoization of five-argument function +for5 :: (((k1, k2, k3, k4, k5) -> mv) -> (k1, k2, k3, k4, k5) -> mv) -> (k1 -> k2 -> k3 -> k4 -> k5 -> mv) -> k1 -> k2 -> k3 -> k4 -> k5 -> mv +for5 m f a b c d e = m (\(a',b',c',d',e') -> f a' b' c' d' e') (a,b,c,d,e) + -------------- -- Lattices -- -------------- diff --git a/templates/course.hamlet b/templates/course.hamlet index 197869f18..4492a29e2 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -225,13 +225,9 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) $if registrationOpen $# regForm is defined through templates/widgets/registerForm ^{regForm} - $if isJust mApplication && courseApplicationsRequired course -

+ $if (isJust mApplication && courseApplicationsRequired course) && mayReRegister +

_{MsgCourseApplicationDeleteToEdit} - $else - $if isJust registration -

- _{MsgCourseRegistrationDeleteToEdit}

_{MsgCourseMaterial}