fix(exams): Fix registration

messages/uniworx/de.msg

@@ -878,6 +878,7 @@ AuthTagTutor: Nutzer ist Tutor
 AuthTagTime: Zeitliche Einschränkungen sind erfüllt
 AuthTagCourseRegistered: Nutzer ist Kursteilnehmer
 AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer
+AuthTagExamRegistered: Nutzer ist Klausurteilnehmer
 AuthTagParticipant: Nutzer ist mit Kurs assoziiert
 AuthTagRegisterGroup: Nutzer ist nicht Mitglied eines anderen Tutoriums mit der selben Registrierungs-Gruppe
 AuthTagCapacity: Kapazität ist ausreichend
@@ -1145,4 +1146,6 @@ ExamResult: Klausurergebnis
 
 ExamRegisteredSuccess exam@ExamName: Erfolgreich zur Klausur #{exam} angemeldet
 ExamDeregisteredSuccess exam@ExamName: Erfolgreich von der Klausur #{exam} abgemeldet
-ExamRegistered: Angemeldet
+ExamRegistered: Angemeldet
+ExamNotRegistered: Nicht angemeldet
+ExamRegistration: Anmeldung

src/Foundation.hs

@@ -797,6 +797,33 @@ tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case rout
     guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
     return Authorized
   r -> $unsupportedAuthPredicate AuthTutorialRegistered r
+tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of
+  CExamR tid ssh csh examn _ -> exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.select . 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
+      return (E.countRows :: E.SqlExpr (E.Value Int64))
+    guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
+    return Authorized
+  CourseR tid ssh csh _ -> exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.select . 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
+      return (E.countRows :: E.SqlExpr (E.Value Int64))
+    guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
+    return Authorized
+  r -> $unsupportedAuthPredicate AuthExamRegistered r
 tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
   CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
     let authorizedIfExists f = do

src/Handler/Exam.hs

@@ -634,7 +634,7 @@ getEShowR tid ssh csh examn = do
   cTime <- liftIO getCurrentTime
   mUid <- maybeAuthId
   
-  (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences) <- runDB $ do
+  (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister)) <- runDB $ do
     exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
 
     let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
@@ -671,9 +671,30 @@ getEShowR tid ssh csh examn = do
 
     let occurrences = map (over _2 E.unValue) occurrencesRaw
 
-    return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences)
+    registered <- for mUid $ existsBy . UniqueExamRegistration eId
+    mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
+
+    return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister))
 
   let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
+      registerWidget
+        | Just isRegistered <- registered
+        , mayRegister = Just $ do
+            (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
+            [whamlet|
+              <p>
+                $if isRegistered
+                  _{MsgExamRegistered}
+                $else
+                  _{MsgExamNotRegistered}
+            |]
+            wrapForm examRegisterForm def
+              { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
+              , formEncoding = examRegisterEnctype
+              , formSubmit = FormNoSubmit
+            }
+        | fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|]
+        | otherwise = Nothing
 
   let heading = prependCourseTitle tid ssh csh $ CI.original examName
 

src/Model/Types/Security.hs

@@ -42,6 +42,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthTutor
   | AuthCourseRegistered
   | AuthTutorialRegistered
+  | AuthExamRegistered
   | AuthParticipant
   | AuthTime
   | AuthMaterials

templates/exam-show.hamlet

@@ -81,6 +81,10 @@ $maybe desc <- examDescription
           \ ^{isVisible False}
       <dd .deflist__dd>
         $# TODO
+    $maybe registerWdgt <- registerWidget
+      <dt .deflist__dt>_{MsgExamRegistration}
+      <dd .deflist__dd>^{registerWdgt}
+    
 
 $if not (null occurrences)
   <section>