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

Fixes #646

BREAKING CHANGE: AccessPredicates now take continuation

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
 

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.
 

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

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

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.

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'

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

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

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

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
-            <p>
+          $if (isJust mApplication && courseApplicationsRequired course) && mayReRegister
+            <p .explanation>
               _{MsgCourseApplicationDeleteToEdit}
-          $else
-            $if isJust registration
-              <p>
-                _{MsgCourseRegistrationDeleteToEdit}
   
   <dt .deflist__dt>
     _{MsgCourseMaterial}