diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 07248ce88..fb215fdd6 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -12,6 +12,7 @@ BtnCourseDeregister: Vom Kurs abmelden BtnCourseApply: Zum Kurs bewerben BtnCourseRetractApplication: Bewerbung zum Kurs zurückziehen BtnExamRegister: Anmelden zur Prüfung +BtnExamRegisterOccurrence: Anmelden zum Prüfungstermin/-raum BtnExamDeregister: Von der Prüfung abmelden BtnHijack: Sitzung übernehmen BtnSave: Speichern @@ -99,6 +100,7 @@ CourseCapacity: Kapazität CourseCapacityTip: Anzahl erlaubter Kursanmeldungen, leer lassen für unbeschränkte Kurskapazität CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei. TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei. +ExamOccurrenceNoCapacity: Zu diesem Termin/Raum sind keine Plätze mehr frei. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet. CourseRegistration: Kursanmeldung CourseRegisterOpen: Anmeldung möglich @@ -409,6 +411,7 @@ UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung e UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert. UnauthorizedAllocationRegistered: Sie sind nicht als Teilnehmer für diese Zentralanmeldung registriert. UnauthorizedExamResult: Sie haben keine Ergebnisse in dieser Prüfung. +UnauthorizedExamOccurrenceRegistration: Anmeldung zur Klausur erfolgt nicht inkl. Raum/Termin. UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert. UnauthorizedParticipantSelf: Sie sind kein Teilnehmer dieser Veranstaltung. UnauthorizedApplicant: Angegebener Benutzer hat sich nicht für diese Veranstaltung beworben. @@ -1263,6 +1266,8 @@ AuthTagAllocationRegistered: Nutzer nimmt an der Zentralanmeldung teil AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer AuthTagExamRegistered: Nutzer ist Prüfungsteilnehmer AuthTagExamResult: Nutzer hat Prüfungsergebnisse +AuthTagExamOccurrenceRegistered: Nutzer ist für Prüfungsraum/-termin angemeldet +AuthTagExamOccurrenceRegistration: Anmeldung zur Klausur erfolgt inkl. Raum/Termin AuthTagParticipant: Nutzer ist mit Kurs assoziiert AuthTagApplicant: Nutzer ist mit Bewerber zum Kurs AuthTagRegisterGroup: Nutzer ist nicht Mitglied eines anderen Tutoriums mit der selben Registrierungs-Gruppe @@ -1522,6 +1527,8 @@ ExamNoBonus': Kein automatischer Bonus ExamBonusPoints': Umrechnung von Übungspunkten ExamBonusManual': Manuelle Berechnung +ExamRegisterForOccurrence: Anmeldung zur Klausur erfolgt durch Anmeldung zu einem Termin/Raum + ExamBonusAchieved: Bonuspunkte ExamEditHeading examn@ExamName: #{examn} bearbeiten @@ -1534,17 +1541,19 @@ ExamBonusRound: Bonus runden auf ExamBonusRoundNonPositive: Vielfaches, auf das gerundet werden soll, muss positiv und größer null sein ExamBonusRoundTip: Bonuspunkte werden kaufmännisch auf ein Vielfaches der angegeben Zahl gerundet. -ExamAutomaticOccurrenceAssignment: Automatische Termin- bzw. Raumzuteilung -ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden? Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist trotzdem möglich. +ExamAutomaticOccurrenceAssignment: Automatische oder selbständige Termin- bzw. Raumzuteilung +ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden oder sich selbstständig einen Raum bzw. Termin aussuchen dürfen? Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist trotzdem möglich. ExamOccurrenceRule: Verfahren ExamOccurrenceRuleParticipant: Termin- bzw. Raumzuteilungsverfahren -ExamRoomManual': Keine automatische Zuteilung +ExamRoomManual': Keine automatische bzw. selbstständige Zuteilung ExamRoomSurname': Nach Nachname ExamRoomMatriculation': Nach Matrikelnummer ExamRoomRandom': Zufällig pro Teilnehmer +ExamRoomFifo': Auswahl durch Teilnehmer bei Anmeldung ExamOccurrence: Termin/Raum ExamNoOccurrence: Kein Termin/Raum +ExamNoSuchOccurrence: Termin/Raum existiert nicht (mehr) ExamOccurrences: Prüfungen ExamRooms: Räume ExamRoomAlreadyExists: Prüfung ist bereits eingetragen @@ -1557,7 +1566,8 @@ ExamRoomStart: Beginn ExamRoomEnd: Ende ExamRoomDescription: Beschreibung ExamTimeTip: Nur zur Information der Studierenden, die tatsächliche Zeitangabe erfolgt pro Prüfung -ExamRoomRegistered: Zugeteilt +ExamRoomAssigned: Zugeteilt +ExamRoomRegistered: Anmeldung ExamOccurrenceStart: Prüfungsbeginn @@ -1603,6 +1613,7 @@ ExamDeregisteredSuccess exam@ExamName: Erfolgreich von der Prüfung #{exam} abge ExamRegistered: Zur Prüfung angemeldet ExamNotRegistered: Nicht zur Prüfung angemeldet ExamRegistration: Prüfungsanmeldung +ExamLoginToRegister: Um sich zum Kurs anzumelden müssen Sie zunächst in Uni2work anmelden ExamRegisterToMustBeAfterRegisterFrom: "Anmeldung ab" muss vor "Anmeldung bis" liegen ExamDeregisterUntilMustBeAfterRegisterFrom: "Abmeldung bis" muss nach "Anmeldung bis" liegen diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index f071b9dae..a39d5fd77 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -12,6 +12,7 @@ BtnCourseDeregister: Leave course BtnCourseApply: Apply for course BtnCourseRetractApplication: Retract application BtnExamRegister: Enrol for exam +BtnExamRegisterOccurrence: Enrol for exam occurrence/room BtnExamDeregister: Leave exam BtnHijack: Hijack session BtnSave: Save @@ -99,6 +100,7 @@ CourseCapacity: Capacity CourseCapacityTip: Maximum permissable number of enrolments for this course; leave empty for unlimited capacity CourseNoCapacity: Course has reached maximum capacity TutorialNoCapacity: Tutorial has reached maximum capacity +ExamOccurrenceNoCapacity: Occurrence/Room has reached maximum capacity CourseNotEmpty: There are currently no participants enrolled for this course. CourseRegistration: Enrolment CourseRegisterOpen: Enrolment is allowed @@ -407,6 +409,7 @@ UnauthorizedCorrectorAny: You are no corrector for any course. UnauthorizedRegistered: You are no participant in this course. UnauthorizedAllocationRegistered: You are no participant in this central allocation. UnauthorizedExamResult: You have no results in this exam. +UnauthorizedExamOccurrenceRegistration: Registration for exam is not done including occurrence/room. UnauthorizedParticipant: The specified user is no participant of this course. UnauthorizedParticipantSelf: You are no participant of this course. UnauthorizedApplicant: The specified user is no applicant for this course. @@ -1262,6 +1265,8 @@ AuthTagAllocationRegistered: User participates in central allocation AuthTagTutorialRegistered: User is tutorial participant AuthTagExamRegistered: User is exam participant AuthTagExamResult: User has an exam result +AuthTagExamOccurrenceRegistered: User is registered for exam occurrence/room +AuthTagExamOccurrenceRegistration: Registration for exam is done including occurrence/room AuthTagParticipant: User participates in course AuthTagApplicant: User is applicant for course AuthTagRegisterGroup: User is not participant in any tutorial of the same registration group @@ -1520,6 +1525,8 @@ ExamNoBonus': No automatic exam bonus ExamBonusPoints': Compute from exercise achievements ExamBonusManual': Manual computation +ExamRegisterForOccurrence: Registration for this exam is done by registering for an occurrence/room + ExamBonusAchieved: Bonus points ExamEditHeading examn: Edit #{examn} @@ -1532,17 +1539,19 @@ ExamBonusRound: Round bonus to ExamBonusRoundNonPositive: Rounding multiple must be positive and greater than zero ExamBonusRoundTip: Bonus points are rounded commercially to a multiple of the given number -ExamAutomaticOccurrenceAssignment: Automatically assign occurrence/room -ExamAutomaticOccurrenceAssignmentTip: Should exam participants be distributed automatically among the configured occurrences/rooms? Manipulation of the distribution and manually assigning participants remains possible. +ExamAutomaticOccurrenceAssignment: Selection of occurrences/rooms for/by participants +ExamAutomaticOccurrenceAssignmentTip: Should exam participants be distributed automatically among the configured occurrences/rooms? Should they instead be permitted to autonomously choose an occurrence/a room? Manipulation of the distribution and manually assigning participants remains possible. ExamOccurrenceRule: Procedure ExamOccurrenceRuleParticipant: Occurrence/room assignment procedure -ExamRoomManual': No automatic assignment +ExamRoomManual': No automatic or autonomous assignment ExamRoomSurname': By surname ExamRoomMatriculation': By matriculation ExamRoomRandom': Randomly +ExamRoomFifo': Selected by the participants when registering ExamOccurrence: Occurrence/room ExamNoOccurrence: No occurrence/room +ExamNoSuchOccurrence: Occurrence/Room does not exist (anymore) ExamOccurrences: Exams ExamRooms: Rooms ExamRoomAlreadyExists: Occurrence already configured @@ -1555,7 +1564,8 @@ ExamRoomStart: Start ExamRoomEnd: End ExamRoomDescription: Description ExamTimeTip: Only for informational purposes. The actual times are set for each occurrence/room -ExamRoomRegistered: Assigned +ExamRoomAssigned: Assigned +ExamRoomRegistered: Registration ExamOccurrenceStart: Exam starts @@ -1601,6 +1611,7 @@ ExamDeregisteredSuccess exam: Successufly deregistered from the exam #{exam} ExamRegistered: Registered for the exam ExamNotRegistered: Not registered for the exam ExamRegistration: Exam registration +ExamLoginToRegister: Your need to login to Uni2work before you can register for this course. ExamRegisterToMustBeAfterRegisterFrom: "Register to" must be after "register from" ExamDeregisterUntilMustBeAfterRegisterFrom: "Deregister until" must be after "register from" diff --git a/routes b/routes index 24e863319..2304d6d34 100644 --- a/routes +++ b/routes @@ -173,6 +173,7 @@ /users/new EAddUserR GET POST /users/invite EInviteR GET POST /register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result + /register/#ExamOccurrenceName ERegisterOccR POST !exam-occurrence-registrationANDtimeANDcapacityANDcourse-registeredAND¬exam-occurrence-registered !exam-occurrence-registrationANDtimeANDexam-occurrence-registeredAND¬exam-result /grades EGradesR GET POST !exam-office /apps CApplicationsR GET POST !/apps/files CAppsFilesR GET diff --git a/src/Foundation.hs b/src/Foundation.hs index 050b6d1aa..dd390b7b8 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -504,9 +504,9 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh 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 + registration <- case mAuthId of + Just uid -> $cachedHereBinary (eId, uid) . lift . getBy $ UniqueExamRegistration eId uid + Nothing -> return Nothing let visible = NTop examVisibleFrom <= NTop (Just cTime) @@ -515,11 +515,23 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of EUsersR -> guard $ NTop examStart <= NTop (Just 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 + | is _Nothing registration + -> guard $ visible + && NTop examRegisterFrom <= NTop (Just cTime) + && NTop (Just cTime) <= NTop examRegisterTo + | otherwise + -> guard $ visible + && NTop (Just cTime) <= NTop examDeregisterUntil + ERegisterOccR occn -> do + occId <- (>>= hoistMaybe) . $cachedHereBinary (eId, occn) . lift . getKeyBy $ UniqueExamOccurrence eId occn + if + | (registration >>= examRegistrationOccurrence . entityVal) == Just occId + -> guard $ visible + && NTop (Just cTime) <= NTop examDeregisterUntil + | otherwise + -> guard $ visible + && NTop examRegisterFrom <= NTop (Just cTime) + && NTop (Just cTime) <= NTop examRegisterTo _ -> return () return Authorized @@ -758,6 +770,59 @@ tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case rout guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) return Authorized r -> $unsupportedAuthPredicate AuthTutorialRegistered r +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 + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. exam E.^. ExamName E.==. E.val examn + E.&&. exam E.^. ExamOccurrenceRule E.==. E.val (Just ExamRoomFifo) + guardMExceptT isOccurrenceRegistration (unauthorizedI MsgUnauthorizedExamOccurrenceRegistration) + return Authorized + r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistration r +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 + E.on $ E.just (examOccurrence E.^. ExamOccurrenceId) E.==. examRegistration E.^. ExamRegistrationOccurrence + E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId + E.&&. examOccurrence E.^. ExamOccurrenceName E.==. E.val occn + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. exam E.^. ExamName E.==. E.val examn + guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + 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 + E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. exam E.^. ExamName E.==. E.val examn + E.&&. E.not_ (E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence) + guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + CourseR tid ssh csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do + E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. E.not_ (E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence) + guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistered r tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of CExamR tid ssh csh examn _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId @@ -768,7 +833,7 @@ tagAccessPredicate AuthExamRegistered = 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 - E.&&. exam E.^. ExamName E.==. E.val examn + E.&&. exam E.^. ExamName E.==. E.val examn guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) return Authorized CourseR tid ssh csh _ -> exceptT return return $ do @@ -933,6 +998,13 @@ tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh 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 + Entity occId ExamOccurrence{..} <- $cachedHereBinary (eid, occn) . MaybeT . getBy $ UniqueExamOccurrence eid occn + registered <- $cachedHereBinary occId . lift $ fromIntegral <$> count [ ExamRegistrationOccurrence ==. Just occId, ExamRegistrationExam ==. eid ] + guard $ examOccurrenceCapacity > registered + return Authorized CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity tutId Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn @@ -1791,6 +1863,7 @@ instance YesodBreadcrumbs UniWorX where ECInviteR -> i18nCrumb MsgBreadcrumbExamCorrectorInvite . Just $ CExamR tid ssh csh examn EShowR EInviteR -> i18nCrumb MsgBreadcrumbExamParticipantInvite . Just $ CExamR tid ssh csh examn EShowR ERegisterR -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR + ERegisterOccR _occn -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of TUsersR -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do diff --git a/src/Handler/Exam/Register.hs b/src/Handler/Exam/Register.hs index cc8e387a7..f040df069 100644 --- a/src/Handler/Exam/Register.hs +++ b/src/Handler/Exam/Register.hs @@ -1,6 +1,7 @@ module Handler.Exam.Register ( ButtonExamRegister(..) , postERegisterR + , postERegisterOccR ) where import Import @@ -8,45 +9,81 @@ import Import import Handler.Utils import Handler.Utils.Exam +import Database.Persist.Sql (deleteWhereCount) + -- Dedicated ExamRegistrationButton -data ButtonExamRegister = BtnExamRegister | BtnExamDeregister - deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +data ButtonExamRegister = BtnExamRegisterOccurrence + | BtnExamRegister + | BtnExamDeregister + deriving (Enum, Bounded, Eq, Ord, Read, Show, Generic, Typeable) instance Universe ButtonExamRegister instance Finite ButtonExamRegister -nullaryPathPiece ''ButtonExamRegister $ camelToPathPiece' 1 -embedRenderMessage ''UniWorX ''ButtonExamRegister id +nullaryPathPiece ''ButtonExamRegister $ camelToPathPiece' 2 + instance Button UniWorX ButtonExamRegister where - btnClasses BtnExamRegister = [BCIsButton, BCPrimary] - btnClasses BtnExamDeregister = [BCIsButton, BCDanger] + btnClasses BtnExamRegisterOccurrence = [BCIsButton, BCPrimary] + btnClasses BtnExamRegister = [BCIsButton, BCPrimary] + btnClasses BtnExamDeregister = [BCIsButton, BCDanger] - btnLabel BtnExamRegister = [whamlet|#{iconExamRegister True} _{MsgBtnExamRegister}|] - btnLabel BtnExamDeregister = [whamlet|#{iconExamRegister False} _{MsgBtnExamDeregister}|] + btnLabel BtnExamRegisterOccurrence = [whamlet|#{iconExamRegister True } _{MsgBtnExamRegisterOccurrence}|] + btnLabel BtnExamRegister = [whamlet|#{iconExamRegister True } _{MsgBtnExamRegister}|] + btnLabel BtnExamDeregister = [whamlet|#{iconExamRegister False} _{MsgBtnExamDeregister}|] postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html - postERegisterR tid ssh csh examn = do Entity uid User{..} <- requireAuth Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn - ((btnResult, _), _) <- runFormPost buttonForm + ((btnResult, _), _) <- runFormPost $ buttonForm' [BtnExamRegister, BtnExamDeregister] formResult btnResult $ \case + BtnExamDeregister -> do + runDB $ do + deleted <- deleteWhereCount [ExamRegistrationExam ==. eId, ExamRegistrationUser ==. uid] + unless (deleted <= 0) $ + audit $ TransactionExamDeregister eId uid + addMessageIconI Success IconExamRegisterFalse $ MsgExamDeregisteredSuccess examn + redirect $ CExamR tid ssh csh examn EShowR BtnExamRegister -> do runDB $ do now <- liftIO getCurrentTime - insert_ $ ExamRegistration eId uid Nothing now + void $ upsertBy (UniqueExamRegistration eId uid) (ExamRegistration eId uid Nothing now) [ExamRegistrationTime =. now] audit $ TransactionExamRegister eId uid - addMessageIconI Success IconExamRegisterTrue $ MsgExamRegisteredSuccess examn + addMessageIconI Success IconExamRegisterTrue $ MsgExamRegisteredSuccess examn redirect $ CExamR tid ssh csh examn EShowR + _other -> error "Unexpected due to definition of buttonForm'" + + redirect $ CExamR tid ssh csh examn EShowR + +postERegisterOccR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> ExamOccurrenceName -> Handler Html +postERegisterOccR tid ssh csh examn occn = do + Entity uid User{..} <- requireAuth + (Entity eId Exam{..}, Entity occId ExamOccurrence{..}) <- runDB $ do + eexam@(Entity eId _) <- fetchExam tid ssh csh examn + occ <- getBy404 $ UniqueExamOccurrence eId occn + return (eexam, occ) + + ((btnResult, _), _) <- runFormPost buttonForm + + formResult btnResult $ \case BtnExamDeregister -> do runDB $ do - deleteBy $ UniqueExamRegistration eId uid - audit $ TransactionExamDeregister eId uid - addMessageIconI Info IconExamRegisterFalse $ MsgExamDeregisteredSuccess examn - -- yes, it's a success message, but it should be visually different from a positive success, since most will just note the positive green color! See discussion on commit 5f4925a4 + deleted <- deleteWhereCount [ExamRegistrationExam ==. eId, ExamRegistrationUser ==. uid] + unless (deleted <= 0) $ + audit $ TransactionExamDeregister eId uid + addMessageIconI Success IconExamRegisterFalse $ MsgExamDeregisteredSuccess examn redirect $ CExamR tid ssh csh examn EShowR + BtnExamRegisterOccurrence -> do + runDB $ do + now <- liftIO getCurrentTime + void $ upsertBy (UniqueExamRegistration eId uid) (ExamRegistration eId uid (Just occId) now) [ExamRegistrationOccurrence =. Just occId, ExamRegistrationTime =. now] + audit $ TransactionExamRegister eId uid + addMessageIconI Success IconExamRegisterTrue $ MsgExamRegisteredSuccess examn + redirect $ CExamR tid ssh csh examn EShowR + _other -> error "Unexpected due to definition of buttonForm'" - invalidArgs ["Register/Deregister button required"] + redirect $ CExamR tid ssh csh examn EShowR + diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index 9ee2da005..138a50391 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -30,7 +30,7 @@ getEShowR tid ssh csh examn = do let gradingVisible = NTop (Just cTime) >= NTop examFinished gradingShown <- or2M (return gradingVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR - let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments + let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments || examOccurrenceRule == Just ExamRoomFifo occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR examParts <- sortOn (view $ _entityVal . _examPartNumber) <$> selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ] @@ -58,10 +58,16 @@ getEShowR tid ssh csh examn = do E.orderBy [E.desc registered, E.asc $ examOccurrence E.^. ExamOccurrenceStart, E.asc $ examOccurrence E.^. ExamOccurrenceRoom] return (examOccurrence, registered) - let occurrences = map (over _2 E.unValue) occurrencesRaw + registered <- for mUid $ getBy . UniqueExamRegistration eId + mayRegister <- if + | examOccurrenceRule == Just ExamRoomFifo -> anyM occurrencesRaw $ \(Entity _ ExamOccurrence{..}, _) -> + hasWriteAccessTo . CExamR tid ssh csh examName $ ERegisterOccR examOccurrenceName + | otherwise -> hasWriteAccessTo $ CExamR tid ssh csh examName ERegisterR - registered <- for mUid $ existsBy . UniqueExamRegistration eId - mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True + let occurrences = sortOn sortPred $ map (over _2 E.unValue) occurrencesRaw + where + sortPred (Entity _ ExamOccurrence{..}, registered') + = (Down $ registered' && not mayRegister, examOccurrenceStart, examOccurrenceRoom) lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR @@ -83,12 +89,18 @@ getEShowR tid ssh csh examn = do ] hasRegistration = any snd occurrences - + + mayRegister' <- fmap ((Map.!) . Map.fromList) . for (Nothing : map Just occurrences) $ \case + Nothing -> + fmap (Nothing, ) . hasWriteAccessTo $ CExamR tid ssh csh examName ERegisterR + Just (Entity occId ExamOccurrence{..}, _) -> + fmap (Just occId, ) . hasWriteAccessTo . CExamR tid ssh csh examName $ ERegisterOccR examOccurrenceName let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences - registerWidget - | Just isRegistered <- registered - , mayRegister = Just $ do + registerWidget mOcc + | isRegistered <- is _Just $ join registered + , examOccurrenceRule /= Just ExamRoomFifo || (isRegistered && not (any snd occurrences)) + , mayRegister' (entityKey <$> mOcc) = Just $ do (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered [whamlet|
@@ -102,11 +114,37 @@ getEShowR tid ssh csh examn = do , formEncoding = examRegisterEnctype , formSubmit = FormNoSubmit } - | fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|] + | examOccurrenceRule == Just ExamRoomFifo + , Just (Entity occId ExamOccurrence{..}) <- mOcc + , isRegistered <- (== Just occId) $ examRegistrationOccurrence . entityVal =<< join registered + , mayRegister' (Just occId) = Just $ do + (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegisterOccurrence] [BtnExamDeregister] isRegistered + wrapForm examRegisterForm def + { formAction = Just . SomeRoute . CExamR tid ssh csh examName $ ERegisterOccR examOccurrenceName + , formEncoding = examRegisterEnctype + , formSubmit = FormNoSubmit + } + | is _Nothing mOcc + , is _Nothing registered + = Just [whamlet|_{MsgExamLoginToRegister}|] + | is _Nothing mOcc + , isRegistered <- is _Just $ join registered + = Just + [whamlet| +
+ $if isRegistered + _{MsgExamRegistered} + $else + _{MsgExamNotRegistered} + $if mayRegister + ^{messageTooltip =<< messageI Info MsgExamRegisterForOccurrence} + |] | otherwise = Nothing showMaxPoints = any (has $ _entityVal . _examPartMaxPoints . _Just) examParts showAchievedPoints = not $ null results + showOccurrenceRegisterColumn = occurrenceAssignmentsShown || (mayRegister && examOccurrenceRule == Just ExamRoomFifo) + markUnregisteredOccurrences mOcc = occurrenceAssignmentsShown && hasRegistration && isn't _Just (registerWidget mOcc) let heading = prependCourseTitle tid ssh csh $ CI.original examName diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 57c590204..197e3156b 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -557,6 +557,7 @@ examBonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classify data ExamOccurrenceRule' = ExamRoomSurname' | ExamRoomMatriculation' | ExamRoomRandom' + | ExamRoomFifo' deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ExamOccurrenceRule' instance Finite ExamOccurrenceRule' @@ -569,6 +570,7 @@ classifyExamOccurrenceRule = \case ExamRoomSurname -> ExamRoomSurname' ExamRoomMatriculation -> ExamRoomMatriculation' ExamRoomRandom -> ExamRoomRandom' + ExamRoomFifo -> ExamRoomFifo' examOccurrenceRuleForm :: Maybe ExamOccurrenceRule -> AForm Handler ExamOccurrenceRule examOccurrenceRuleForm = fmap reverseClassify . areq (selectField optionsFinite) (fslI MsgExamOccurrenceRule) . fmap classifyExamOccurrenceRule @@ -577,6 +579,7 @@ examOccurrenceRuleForm = fmap reverseClassify . areq (selectField optionsFinite) ExamRoomSurname' -> ExamRoomSurname ExamRoomMatriculation' -> ExamRoomMatriculation ExamRoomRandom' -> ExamRoomRandom + ExamRoomFifo' -> ExamRoomFifo data ExamGradingRule' = ExamGradingKey' deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index afd09396e..40e6852d5 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -139,6 +139,7 @@ derivePersistFieldJSON ''ExamBonusRule data ExamOccurrenceRule = ExamRoomSurname | ExamRoomMatriculation | ExamRoomRandom + | ExamRoomFifo deriving (Show, Read, Eq, Ord, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index a1df33f56..95f11c217 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -54,6 +54,8 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä | AuthCourseRegistered | AuthTutorialRegistered | AuthExamRegistered + | AuthExamOccurrenceRegistered + | AuthExamOccurrenceRegistration | AuthExamResult | AuthParticipant | AuthApplicant diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 44ff63632..9d385d87b 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -84,7 +84,7 @@ $maybe desc <- examDescription \ ^{isVisible False}