From 99184ff05322573a6958f09e30fa0fdcdd3d665b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 26 Jun 2019 15:25:59 +0200 Subject: [PATCH] feat(exams): exam registration --- messages/uniworx/de.msg | 8 ++++++-- routes | 5 ++++- src/Foundation.hs | 21 ++++++++++++++++++--- src/Handler/Course.hs | 16 +++++++++++++++- src/Handler/Exam.hs | 34 +++++++++++++++++++++++++++++++++- 5 files changed, 76 insertions(+), 8 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8c713c0a0..492a08b54 100644 --- a/messages/uniworx/de.msg +++ b/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 \ No newline at end of file +ExamResult: Klausurergebnis + +ExamRegisteredSuccess exam@ExamName: Erfolgreich zur Klausur #{exam} angemeldet +ExamDeregisteredSuccess exam@ExamName: Erfolgreich von der Klausur #{exam} abgemeldet +ExamRegistered: Angemeldet \ No newline at end of file diff --git a/routes b/routes index 9d35caa33..a6241127d 100644 --- a/routes +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 821427118..97dd384f5 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index f849fb282..f55328ca5 100644 --- a/src/Handler/Course.hs +++ b/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 ) diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index dffde8e32..f44a78abf 100644 --- a/src/Handler/Exam.hs +++ b/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"]