feat(allocations): prevent course (de)registrations

messages/uniworx/de.msg

@@ -339,6 +339,9 @@ UnauthorizedPWHash: Angegebener Nutzer meldet sich nicht mit Uni2work-Kennung an
 
 UnauthorizedPasswordResetToken: Dieses Authorisierungs-Token kann nicht mehr zum Passwort ändern benutzt werden
 
+UnauthorizedAllocatedCourseRegister: Direkte Anmeldungen zum Kurs sind aufgrund einer Zentralanmeldung aktuell nicht gestattet
+UnauthorizedAllocatedCourseDeregister: Abmeldungen vom Kurs sind aufgrund einer Zentralanmeldung aktuell nicht gestattet
+
 EMail: E-Mail
 EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
 NotAParticipant email@UserEmail tid@TermId csh@CourseShorthand: #{email} ist nicht im Kurs #{tid}-#{csh} angemeldet.
@@ -952,6 +955,7 @@ AuthTagLecturer: Nutzer ist Dozent
 AuthTagCorrector: Nutzer ist Korrektor
 AuthTagTutor: Nutzer ist Tutor
 AuthTagTime: Zeitliche Einschränkungen sind erfüllt
+AuthTagAllocationTime: Zeitliche Einschränkungen durch Zentralanmeldung sind erfüllt
 AuthTagCourseRegistered: Nutzer ist Kursteilnehmer
 AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer
 AuthTagExamRegistered: Nutzer ist Klausurteilnehmer

routes

@@ -86,12 +86,12 @@
 !/course/new                CourseNewR         GET POST        !lecturer
 /course/#TermId/#SchoolId/#CourseShorthand CourseR             !lecturer:
   /                           CShowR           GET             !free
-  /register                   CRegisterR       GET POST        !timeANDcapacity
+  /register                   CRegisterR       GET POST        !timeANDcapacityANDallocation-time !lecturerANDallocation-time
   /edit                       CEditR           GET POST
   /lecturer-invite            CLecInviteR      GET POST
   /delete                     CDeleteR         GET POST        !lecturerANDempty
   /users                      CUsersR          GET POST
-  !/users/new                 CAddUserR        GET POST        !lecturerANDtime -- TODO: time
+  !/users/new                 CAddUserR        GET POST        !lecturerANDallocation-time
   !/users/invite              CInviteR         GET POST
   /users/#CryptoUUIDUser      CUserR           GET POST        !lecturerANDparticipant
   /correctors                 CHiWisR          GET
@@ -150,7 +150,7 @@
     /edit                       EEditR         GET POST
     /corrector-invite           ECInviteR      GET POST
     /users                      EUsersR        GET POST
-    /users/new                  EAddUserR      GET POST        -- TODO: add check that this is not used to circumvent CAddUserR
+    /users/new                  EAddUserR      GET POST
     /users/invite               EInviteR       GET POST
     /register                   ERegisterR         POST        !timeANDcourse-registered !timeANDexam-registered
 

src/Foundation.hs

@@ -795,6 +795,42 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
     return Authorized
 
   r -> $unsupportedAuthPredicate AuthTime r
+tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
+  CourseR tid ssh csh CRegisterR -> do
+    now <- liftIO getCurrentTime
+    mba <- mbAllocation tid ssh csh
+    case mba of
+      Nothing -> return Authorized
+      Just (cid, Allocation{..}) -> do
+        registered <- case mAuthId of
+          Just uid -> $cachedHereBinary (uid, cid) . existsBy $ UniqueParticipant uid cid
+          _        -> return False
+        if
+          | not registered
+          , NTop allocationRegisterByCourse >= NTop (Just now)
+            -> unauthorizedI MsgUnauthorizedAllocatedCourseRegister
+          | registered
+          , NTop (Just now) >= NTop allocationOverrideDeregister
+            -> unauthorizedI MsgUnauthorizedAllocatedCourseDeregister
+          | otherwise
+            -> return Authorized
+
+  CourseR tid ssh csh CAddUserR -> do
+    now <- liftIO getCurrentTime
+    mba <- mbAllocation tid ssh csh
+    case mba of
+      Just (_, Allocation{..})
+        | NTop allocationRegisterByStaffTo <= NTop (Just now)
+        , NTop allocationRegisterByStaffFrom >= NTop (Just now)
+          -> unauthorizedI MsgUnauthorizedAllocatedCourseRegister
+      _other -> return Authorized
+  
+  r -> $unsupportedAuthPredicate AuthAllocationTime r
+  where
+    mbAllocation tid ssh csh = $cachedHereBinary (tid, ssh, csh) . runMaybeT $ do
+      cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+      Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid
+      (cid,) <$> MaybeT (get allocationCourseAllocation)
 tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of
   CourseR tid ssh csh _ -> exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId

src/Handler/Exam/AddUser.hs

@@ -134,6 +134,8 @@ postEAddUserR tid ssh csh examn = do
       unless registerCourse $ 
         throwError $ mempty { aurNoCourseRegistration = pure userEmail }
 
+      guardAuthResult =<< lift (lift $ evalAccessDB (CourseR tid ssh csh CAddUserR) True)
+
       features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
 
       let courseParticipantField

src/Model/Types/Security.hs

@@ -47,6 +47,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthExamRegistered
   | AuthParticipant
   | AuthTime
+  | AuthAllocationTime
   | AuthMaterials
   | AuthOwner
   | AuthRated