feat(exams): exam registration

messages/uniworx/de.msg

@@ -1104,7 +1104,7 @@ ExamOccurrences: Prüfungen
 ExamRoomAlreadyExists: Prüfung ist bereits eingetragen
 ExamRoom: Raum
 ExamRoomCapacity: Kapazität
-ExamRoomCapacityNonPositive: Kapazität muss positiv und größer null sein
+ExamRoomCapacityNegative: Kapazität darf nicht negativ sein
 ExamRoomTime: Termin
 ExamRoomStart: Beginn
 ExamRoomEnd: Ende
@@ -1141,4 +1141,8 @@ ExamBonusPointsPassed possible@Points: Maximal #{showFixed True possible} Klausu
 
 ExamPassed: Bestanden
 ExamNotPassed: Nicht bestanden
-ExamResult: Klausurergebnis
+ExamResult: Klausurergebnis
+
+ExamRegisteredSuccess exam@ExamName: Erfolgreich zur Klausur #{exam} angemeldet
+ExamDeregisteredSuccess exam@ExamName: Erfolgreich von der Klausur #{exam} abgemeldet
+ExamRegistered: Angemeldet

routes

@@ -143,7 +143,10 @@
     /show                       EShowR         GET             !time
     /edit                       EEditR         GET POST
     /corrector-invite           ECInviteR      GET POST
-
+    /users                      EUsersR        GET POST        !timeANDcorrector
+    /users/new                  EAddUserR      GET POST
+    /users/invite               EInviteR       GET POST
+    /register                   ERegisterR         POST        !timeANDcourse-registered !timeANDexam-registered
 
 /subs          CorrectionsR          GET POST !corrector !lecturer
 /subs/upload   CorrectionsUploadR    GET POST !corrector !lecturer

src/Foundation.hs

@@ -650,12 +650,27 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return
       guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor)
       return Authorized
 tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> 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
-    Entity _ Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
+    Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
     cTime <- liftIO getCurrentTime
+    registered <- case mAuthId of
+      Just uid -> $cachedHereBinary (eId, uid) . lift . existsBy $ UniqueExamRegistration eId uid
+      Nothing  -> return False
 
-    guard $ NTop examVisibleFrom <= NTop (Just cTime)
+    let visible = NTop examVisibleFrom <= NTop (Just cTime)
+
+    case subRoute of
+      EShowR     -> guard visible
+      EUsersR    -> guard $ examStart <= cTime
+                         && NTop (Just cTime) <= NTop examFinished
+      ERegisterR
+        | not registered -> guard $ visible
+                                 && NTop examRegisterFrom <= NTop (Just cTime)
+                                 && NTop (Just cTime) <= NTop examRegisterTo
+        | otherwise      -> guard $ visible
+                                 && NTop (Just cTime) <= NTop examDeregisterUntil
+      _          -> return ()
 
     return Authorized
   

src/Handler/Course.hs

@@ -430,7 +430,21 @@ getCShowR tid ssh csh = do
                 $maybe endT' <- endT
                   \ – #{endT'}
               |]
-
+          , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
+              mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
+              isRegistered <- case mbAid of
+                Nothing  -> return False
+                Just uid -> existsBy $ UniqueExamRegistration eId uid
+              if
+                | mayRegister -> do
+                    (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
+                    return $ wrapForm examRegisterForm def
+                      { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
+                      , formEncoding = examRegisterEnctype
+                      , formSubmit = FormNoSubmit
+                      }
+                | isRegistered -> return [whamlet|_{MsgExamRegistered}|]
+                | otherwise -> return mempty
           ]
         dbtSorting = Map.fromList
           [ ("name", SortColumn $ \exam -> exam E.^. ExamName )

src/Handler/Exam.hs

@@ -275,7 +275,7 @@ examOccurrenceForm prev = wFormToAForm $ do
     examOccurrenceForm' nudge mPrev csrf = do
       (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
       (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "name")) (eofRoom <$> mPrev)
-      (eofCapacityRes, eofCapacityView) <- mpreq (posIntFieldI MsgExamRoomCapacityNonPositive) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev)
+      (eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev)
       (eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev)
       (eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev)
       (eofDescRes, eofDescView) <- mopt htmlFieldSmall ("" & addName (nudge "description")) (eofDescription <$> mPrev)
@@ -691,3 +691,35 @@ getEShowR tid ssh csh examn = do
       examBonusW :: ExamBonusRule -> Widget
       examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
     $(widgetFile "exam-show")
+
+getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
+getEUsersR = postEUsersR
+postEUsersR = error "postEUsersR"
+
+getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
+getEAddUserR = postEAddUserR
+postEAddUserR = error "postEAddUserR"
+
+getEInviteR, postEInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
+getEInviteR = postEInviteR
+postEInviteR = error "postEInviteR"
+
+postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
+postERegisterR tid ssh csh examn = do
+  uid <- requireAuthId
+
+  Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn
+
+  ((btnResult, _), _) <- runFormPost buttonForm
+
+  formResult btnResult $ \case
+    BtnRegister -> do
+      runDB . void . insert $ ExamRegistration eId uid Nothing
+      addMessageI Success $ MsgExamRegisteredSuccess examn
+      redirect $ CExamR tid ssh csh examn EShowR
+    BtnDeregister -> do
+      runDB . deleteBy $ UniqueExamRegistration eId uid
+      addMessageI Success $ MsgExamDeregisteredSuccess examn
+      redirect $ CExamR tid ssh csh examn EShowR
+
+  invalidArgs ["Register/Deregister button required"]