feat(exams): exam registration
This commit is contained in:
Gregor Kleen
parent
0428e8b921
commit
99184ff053
@ -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
|
||||
5
routes
5
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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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 )
|
||||
|
||||
@ -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"]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user