fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(course): warning if re-registration is not possible

Browse Source 
Fixes #646

BREAKING CHANGE: AccessPredicates now take continuation
This commit is contained in:
Gregor Kleen 2020-11-02 19:31:25 +01:00
parent b6664089f7
commit 4451ceedf7
10 changed files with 143 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/de-de-formal.msg
View File

@ -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. 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. 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 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 CourseLoginToRegister: Um sich zum Kurs anzumelden müssen Sie zunächst in Uni2work anmelden

2
messages/uniworx/en-eu.msg
View File

@ -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. CourseApplicationDeleteToEdit: You need to withdraw your application and reapply to edit your application.
CourseRegistrationDeleteToEdit: You need to deregister and reregister to edit your registration. 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. 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. CourseLoginToRegister: Your need to login to Uni2work before you can register for this course.

145
src/Foundation/Authorization.hs
View File

@ -73,25 +73,27 @@ newtype InvalidAuthTag = InvalidAuthTag Text
instance Exception InvalidAuthTag instance Exception InvalidAuthTag
type AuthTagsEval m = AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
data AccessPredicate data AccessPredicate
= APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) = APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
| APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX 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 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 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 (APPure p) -> runReader (p aid r w) <$> getMsgRenderer
(APHandler p) -> p aid r w (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 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 (APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
(APHandler p) -> lift $ p aid r w (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 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 noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
dnf <- either throwM return $ routeAuthTags currentRoute 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 return False
@ -221,6 +225,8 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
noTokenAuth :: AuthDNF -> AuthDNF noTokenAuth :: AuthDNF -> AuthDNF
noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar 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 guardMExceptT (not $ Set.null bearerAuthority') $ unauthorizedI MsgUnauthorizedTokenInvalidNoAuthority
forM_ bearerAuthority' $ \uid -> do forM_ bearerAuthority' $ \uid -> do
@ -229,12 +235,12 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
authorityVal <- do authorityVal <- do
dnf <- either throwM return $ routeAuthTags route 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 guardExceptT (is _Authorized authorityVal) authorityVal
whenIsJust bearerAddAuth $ \addDNF -> do whenIsJust bearerAddAuth $ \addDNF -> do
$logDebugS "validateToken" $ tshow addDNF $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 guardExceptT (is _Authorized additionalVal) additionalVal
return Authorized return Authorized
@ -286,7 +292,7 @@ maybeCurrentBearerRestrictions = liftHandler . runMaybeT $ do
tagAccessPredicate :: BearerAuthSite UniWorX tagAccessPredicate :: BearerAuthSite UniWorX
=> AuthTag -> AccessPredicate => AuthTag -> AccessPredicate
tagAccessPredicate AuthFree = trueAP 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 -- Courses: access only to school admins
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
@ -323,12 +329,12 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] [] adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] []
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
return Authorized 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 authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False] isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False]
guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice
return Authorized 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 CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
hasUsers <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do 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] isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice]
guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice) guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice)
return Authorized 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 ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation 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] isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation]
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
return Authorized 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 AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation 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] isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation]
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
return Authorized 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 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 AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
myUid <- maybeExceptT AuthenticationRequired $ return mAuthId myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
uid <- decrypt cID uid <- decrypt cID
@ -421,7 +427,7 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
#else #else
return $ Unauthorized "Route under development" return $ Unauthorized "Route under development"
#endif #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 CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isLecturer <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` lecturer) -> do 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 authId <- maybeExceptT AuthenticationRequired $ return mAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] [] void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] []
return Authorized 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 authId <- maybeExceptT AuthenticationRequired $ return mAuthId
resList <- $cachedHereBinary mAuthId . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do 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 $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
@ -488,7 +494,7 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret
_ -> do _ -> do
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
return Authorized 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 CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do 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 guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthExamCorrector r 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 authId <- maybeExceptT AuthenticationRequired $ return mAuthId
resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do 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 $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
@ -536,14 +542,14 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return
_ -> do _ -> do
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor)
return Authorized 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 CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do
Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
guard tutorialTutorControlled guard tutorialTutorControlled
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthTutorControl r 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 CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn
@ -568,7 +574,7 @@ tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route o
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthSubmissionGroup r 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 CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn 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 CourseR tid ssh csh CRegisterR -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh
registered <- case (mbc,mAuthId) of registered <- cont (predDNFSingleton $ PLVariable AuthCourseRegistered) mAuthId route isWrite
(Just (Entity cid _), Just uid) -> $cachedHereBinary (uid, cid) $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive]
_ -> return False
case mbc of case mbc of
(Just (Entity _ Course{courseRegisterFrom, courseRegisterTo})) (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo}))
| not registered | not registered
@ -750,7 +754,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthTime r 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 CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
@ -775,16 +779,14 @@ tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthStaffTime r 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 CourseR tid ssh csh CRegisterR -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
mba <- mbAllocation tid ssh csh mba <- mbAllocation tid ssh csh
case mba of case mba of
Nothing -> return Authorized Nothing -> return Authorized
Just (cid, Allocation{..}) -> do Just (_, Allocation{..}) -> do
registered <- case mAuthId of registered <- cont (predDNFSingleton $ PLVariable AuthCourseRegistered) mAuthId route isWrite
Just uid -> $cachedHereBinary (uid, cid) $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
_ -> return False
if if
| not registered | not registered
, NTop allocationRegisterByCourse >= NTop (Just now) , NTop allocationRegisterByCourse >= NTop (Just now)
@ -821,7 +823,7 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid
(cid,) <$> MaybeT (get allocationCourseAllocation) (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 CourseR tid ssh csh _ -> exceptT return return $ do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
courseVisible <- $cachedHereBinary (tid, ssh, csh) . lift . E.selectExists . E.from $ \course -> do 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) guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthCourseTime r 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 CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do 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) guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthCourseRegistered r 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 CTutorialR tid ssh csh tutn _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId 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 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) guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthTutorialRegistered r 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 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 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.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
@ -882,7 +884,7 @@ tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ route _ -> case ro
guardMExceptT isOccurrenceRegistration (unauthorizedI MsgUnauthorizedExamOccurrenceRegistration) guardMExceptT isOccurrenceRegistration (unauthorizedI MsgUnauthorizedExamOccurrenceRegistration)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistration r 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 CExamR tid ssh csh examn (ERegisterOccR occn) -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId 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 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) guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistered r 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 CExamR tid ssh csh examn _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId 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 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 guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredAnyExam
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthExamRegistered r 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 CExamR tid ssh csh examn _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId 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 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) guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthExamRegistered r 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 AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegistered) $ do
uid <- hoistMaybe mAuthId uid <- hoistMaybe mAuthId
aId <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getKeyBy $ TermSchoolAllocationShort tid ssh ash aId <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getKeyBy $ TermSchoolAllocationShort tid ssh ash
void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthAllocationRegistered r 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 CNewsR tid ssh csh cID _ -> maybeT (unauthorizedI MsgUnauthorizedParticipantSelf) $ do
nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId 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.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh 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 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 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.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh 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 CExamR tid ssh csh examn (ERegisterOccR occn) -> maybeT (unauthorizedI MsgExamOccurrenceNoCapacity) $ do
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
eid <- $cachedHereBinary (cid, examn) . MaybeT . getKeyBy $ UniqueExam cid examn 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) guard $ NTop courseCapacity > NTop (Just registered)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthCapacity r 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 CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn 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 guard $ not hasOther
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthRegisterGroup r 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 EExamListR -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do 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 E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthEmpty r 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 CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
guard courseMaterialFree guard courseMaterialFree
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthMaterials r 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 CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthOwner r 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 CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . exceptT return return $ do
Entity shId Sheet{..} <- maybeTMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) $ do Entity shId Sheet{..} <- maybeTMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) $ do
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh 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 E.&&. E.not_ (E.isNothing $ psFile E.^. PersonalisedSheetFileContent) -- directories don't count
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthPersonalisedSheetFiles r 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 CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
sub <- MaybeT $ get sid sub <- MaybeT $ get sid
guard $ submissionRatingDone sub guard $ submissionRatingDone sub
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthRated r 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 CSheetR tid ssh csh shn _ -> $cachedHereBinary (tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn
guard $ is _Just submissionModeUser guard $ is _Just submissionModeUser
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthUserSubmissions r 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 CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
guard submissionModeCorrector guard submissionModeCorrector
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r 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 referencedUser' <- case route of
AdminUserR cID -> return $ Left cID AdminUserR cID -> return $ Left cID
AdminUserDeleteR 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 | uid == referencedUser -> return Authorized
Nothing -> return AuthenticationRequired Nothing -> return AuthenticationRequired
_other -> unauthorizedI MsgUnauthorizedSelf _other -> unauthorizedI MsgUnauthorizedSelf
tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do tagAccessPredicate AuthIsLDAP = APDB $ \_ _ route _ -> exceptT return return $ do
referencedUser <- case route of referencedUser <- case route of
AdminUserR cID -> return cID AdminUserR cID -> return cID
AdminUserDeleteR cID -> return cID AdminUserDeleteR cID -> return cID
@ -1294,7 +1296,7 @@ tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do
User{..} <- MaybeT $ get referencedUser' User{..} <- MaybeT $ get referencedUser'
guard $ userAuthentication == AuthLDAP guard $ userAuthentication == AuthLDAP
return Authorized return Authorized
tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ do tagAccessPredicate AuthIsPWHash = APDB $ \_ _ route _ -> exceptT return return $ do
referencedUser <- case route of referencedUser <- case route of
AdminUserR cID -> return cID AdminUserR cID -> return cID
AdminUserDeleteR cID -> return cID AdminUserDeleteR cID -> return cID
@ -1308,7 +1310,7 @@ tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ d
User{..} <- MaybeT $ get referencedUser' User{..} <- MaybeT $ get referencedUser'
guard $ is _AuthPWHash userAuthentication guard $ is _AuthPWHash userAuthentication
return Authorized return Authorized
tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthAuthentication = APDB $ \_ mAuthId route _ -> case route of
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId
@ -1329,6 +1331,11 @@ tagAccessPredicate AuthWrite = APPure $ \_ _ isWrite -> do
MsgRenderer mr <- ask MsgRenderer mr <- ask
return $ bool (Unauthorized $ mr MsgUnauthorized) Authorized isWrite 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 authTagSpecificity :: AuthTag -> AuthTag -> Ordering
-- ^ Heuristic for which `AuthTag`s to evaluate first -- ^ Heuristic for which `AuthTag`s to evaluate first
@ -1370,9 +1377,9 @@ routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partiti
| otherwise | otherwise
= Left $ InvalidAuthTag t = 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 -- ^ `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 = do
mr <- getMsgRenderer mr <- getMsgRenderer
let let
@ -1382,11 +1389,11 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf
authTagIsInactive = not . authTagIsActive authTagIsInactive = not . authTagIsActive
evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult 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 where
evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do
$logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite') $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 :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult
evalAuthLiteral PLVariable{..} = evalAuthTag plVar 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 :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
evalAccessFor mAuthId route isWrite = do evalAccessFor mAuthId route isWrite = do
dnf <- either throwM return $ routeAuthTags route 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 :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
evalAccessForDB = evalAccessFor 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 :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult
evalAccessWith assumptions route isWrite = do evalAccessWith assumptions route isWrite = do
mAuthId <- liftHandler maybeAuthId mAuthId <- liftHandler maybeAuthId
tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags (tagActive :: AuthTagActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
dnf <- either throwM return $ routeAuthTags route dnf <- either throwM return $ routeAuthTags route
let dnf' = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) $ Just dnf let adjDNF = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) . Just
case dnf' of evalAdj :: forall m'. MonadAP m' => AuthTagsEval m'
Nothing -> return Authorized evalAdj (adjDNF -> dnf') mAuthId' route' isWrite' = case dnf' of
Just dnf'' -> do Nothing -> return Authorized
(result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf'' mAuthId route isWrite Just dnf'' -> evalAuthTags ('evalAccessWith, assumptions) tagActive evalAdj dnf'' mAuthId' route' isWrite'
result <$ tellSessionJson SessionInactiveAuthTags deactivated 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 :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
evalAccessWithDB = evalAccessWith evalAccessWithDB = evalAccessWith

20
src/Foundation/Routes.hs
View File

@ -40,6 +40,26 @@ deriving instance Generic CourseNewsR
deriving instance Generic CourseEventR deriving instance Generic CourseEventR
deriving instance Generic (Route UniWorX) 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 data RouteChildren
type instance Children RouteChildren a = ChildrenRouteChildren a type instance Children RouteChildren a = ChildrenRouteChildren a
type family ChildrenRouteChildren a where type family ChildrenRouteChildren a where

13
src/Handler/Course/Register.hs
View File

@ -1,7 +1,7 @@
module Handler.Course.Register module Handler.Course.Register
( ButtonCourseRegister(..) ( ButtonCourseRegister(..)
, CourseRegisterForm(..) , CourseRegisterForm(..)
, courseRegisterForm , courseRegisterForm, courseMayReRegister
, getCRegisterR, postCRegisterR , getCRegisterR, postCRegisterR
, deregisterParticipant , deregisterParticipant
) where ) where
@ -147,18 +147,29 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
E.||. isCourseExamCorrector muid ata (course E.^. CourseId) E.||. isCourseExamCorrector muid ata (course E.^. CourseId)
) )
mayReRegister <- liftHandler . runDB . courseMayReRegister $ Entity cid Course{..}
when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $ when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $
wformMessage =<< messageIconI Warning IconExamRegisterFalse MsgCourseDeregistrationAllocationLog wformMessage =<< messageIconI Warning IconExamRegisterFalse MsgCourseDeregistrationAllocationLog
when (is _Just (registration >>= courseParticipantAllocated . entityVal) && courseDeregisterNoShow) $ when (is _Just (registration >>= courseParticipantAllocated . entityVal) && courseDeregisterNoShow) $
wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoShow wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoShow
when (isRegistered && not mayViewCourseAfterDeregistration) $ when (isRegistered && not mayViewCourseAfterDeregistration) $
wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationFromInvisibleCourse wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationFromInvisibleCourse
unless mayReRegister $
wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoReRegistration
return $ CourseRegisterForm return $ CourseRegisterForm
<$ secretRes <$ secretRes
<*> appTextRes <*> appTextRes
<*> appFilesRes <*> 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. -- | Workaround for klicking register button without being logged in.
-- After log in, the user sees a "get request not supported" error. -- After log in, the user sees a "get request not supported" error.

6
src/Handler/Course/Show.hs
View File

@ -28,7 +28,7 @@ getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do getCShowR tid ssh csh = do
mbAid <- maybeAuthId mbAid <- maybeAuthId
now <- liftIO getCurrentTime 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)] [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)]
<- lift . E.select . E.from $ <- lift . E.select . E.from $
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
@ -106,7 +106,9 @@ getCShowR tid ssh csh = do
return $ submissionGroup E.^. SubmissionGroupName return $ submissionGroup E.^. SubmissionGroupName
let submissionGroup = guardOnM (hasSubmissionGroups && is _Just registration) submissionGroup' 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 let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course
mDereg <- traverse (formatTime SelFormatDateTime) mDereg' mDereg <- traverse (formatTime SelFormatDateTime) mDereg'

9
src/Language/Haskell/TH/Instances.hs
View File

@ -7,6 +7,7 @@ module Language.Haskell.TH.Instances
import ClassyPrelude import ClassyPrelude
import Language.Haskell.TH import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Lift (deriveLift) import Language.Haskell.TH.Lift (deriveLift)
import Data.Binary (Binary) import Data.Binary (Binary)
@ -15,6 +16,14 @@ instance Binary Loc
deriveLift ''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 instance Semigroup (Q [Dec]) where
(<>) = liftA2 (<>) (<>) = liftA2 (<>)

10
src/Model/Types/Security.hs
View File

@ -211,6 +211,16 @@ dnfAssumeValue var val
predDNFFalse :: PredDNF a predDNFFalse :: PredDNF a
predDNFFalse = PredDNF Set.empty 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 data UserGroupName
= UserGroupMetrics = UserGroupMetrics

4
src/Utils.hs
View File

@ -1162,6 +1162,10 @@ setLastModified lastModified = do
safeMethods = [ methodGet, methodHead, methodOptions ] 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 -- -- Lattices --
-------------- --------------

8
templates/course.hamlet
View File

@ -225,13 +225,9 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
$if registrationOpen $if registrationOpen
$# regForm is defined through templates/widgets/registerForm $# regForm is defined through templates/widgets/registerForm
^{regForm} ^{regForm}
$if isJust mApplication && courseApplicationsRequired course $if (isJust mApplication && courseApplicationsRequired course) && mayReRegister
<p> <p .explanation>
_{MsgCourseApplicationDeleteToEdit} _{MsgCourseApplicationDeleteToEdit}
$else
$if isJust registration
<p>
_{MsgCourseRegistrationDeleteToEdit}
<dt .deflist__dt> <dt .deflist__dt>
_{MsgCourseMaterial} _{MsgCourseMaterial}