refactor(course-user): modularize

src/Foundation.hs

@@ -1101,6 +1101,14 @@ tagAccessPredicate AuthParticipant = 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
+      -- participant is exam corrector for this course
+      mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
+        E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam
+        E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+        E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val participant
+             E.&&. course E.^. CourseTerm      E.==. E.val tid
+             E.&&. course E.^. CourseSchool    E.==. E.val ssh
+             E.&&. course E.^. CourseShorthand E.==. E.val csh
       -- participant is lecturer for this course
       mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do
         E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
@@ -1108,6 +1116,23 @@ tagAccessPredicate AuthParticipant = 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
+      -- participant has an exam result for this course
+      mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
+        E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
+        E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+        E.where_ $ examResult E.^. ExamResultUser E.==. E.val participant
+             E.&&. course E.^. CourseTerm      E.==. E.val tid
+             E.&&. course E.^. CourseSchool    E.==. E.val ssh
+             E.&&. course E.^. CourseShorthand E.==. E.val csh
+      -- participant is registered for an exam for this course
+      mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
+        E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
+        E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+        E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val participant
+             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 ()
 tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of

src/Handler/Course/User.hs

@@ -20,80 +20,53 @@ import Jobs.Queue
 getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
 getCUserR = postCUserR
 postCUserR tid ssh csh uCId = do
-  -- Has authorization checks (OR):
+  showSex <- maybe False (userShowSex . entityVal) <$> maybeAuth
-  --
+
-  --   - User is current member of course
+  (course, user@(Entity _ User{..}), registered) <- runDB $ do
-  --   - User has submitted in course
+    uid <- decrypt uCId
-  --   - User is member of registered group for course
+    course@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
-  --   - User is member of a tutorial for course
-  --   - User is corrector for course
-  --   - User is a tutor for course
-  --   - User is a lecturer for course
-  let currentRoute = CourseR tid ssh csh (CUserR uCId)
-  Entity dozentId (userShowSex -> showSex) <- requireAuth
-  uid <- decrypt uCId
-  -- DB reads
-  (cid, User{..}, mRegistration, thisUniqueNote, noteText, noteEdits, studies) <- runDB $ do
-    cid  <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-    -- Abfrage Benutzerdaten
     user <- get404 uid
-    registration <- getBy (UniqueParticipant uid cid)
+    registered <- existsBy $ UniqueParticipant uid cid
-    -- Abfrage Teilnehmernotiz
+
-    let thisUniqueNote = UniqueCourseUserNote uid cid
+    return (course, Entity uid user, registered)
-    mbNoteEnt <- getBy thisUniqueNote
+  
-    (noteText,noteEdits) <- case mbNoteEnt of
+  sections <- mapM (runMaybeT . ($ user) . ($ course))
-      Nothing -> return (Nothing,[])
+    [ courseUserProfileSection
-      (Just (Entity noteKey CourseUserNote{courseUserNoteNote})) -> do
+    , courseUserNoteSection
-        noteEdits <- E.select $ E.from $ \(edit `E.InnerJoin` usr) -> do
+    ]
-          E.on     $ edit E.^. CourseUserNoteEditUser E.==. usr E.^. UserId
+
-          E.where_ $ edit E.^. CourseUserNoteEditNote E.==. E.val noteKey
+  -- generate output
-          E.orderBy [E.desc $ edit E.^. CourseUserNoteEditTime]
+  let headingLong
-          E.limit 1 -- more will be shown, if changed here
+        | registered
-          return (edit E.^. CourseUserNoteEditTime, usr E.^. UserEmail, usr E.^. UserDisplayName, usr E.^. UserSurname)
+        , Just sex <- guardOn showSex =<< userSex
-        return (Just courseUserNoteNote, $(unValueN 4) <$> noteEdits)
+        = [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseMemberOf} #{csh} #{tid}|]
-    -- Abfrage Studiengänge
+        | registered
+        = [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseMemberOf} #{csh} #{tid}|]
+        | Just sex <- guardOn showSex =<< userSex
+        = [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseAssociatedWith} #{csh} #{tid}|]
+        | otherwise
+        = [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseAssociatedWith} #{csh} #{tid}|]
+      headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName
+  siteLayout headingLong $ do
+    setTitleI headingShort
+
+    forM_ sections . fromMaybe $ return ()
+
+courseUserProfileSection :: Entity Course -> Entity User -> MaybeT Handler Widget
+courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = _, ..}) = do
+  showSex <- maybe False (userShowSex . entityVal) <$> maybeAuth
+  currentRoute <- MaybeT getCurrentRoute
+
+  (mRegistration, studies) <- lift . runDB $ do
+    registration <- getBy $ UniqueParticipant uid cid
     studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
       E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
       E.on $ studyfeat E.^. StudyFeaturesField  E.==. studyterms  E.^. StudyTermsId
       E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
       return  (studyfeat, studydegree, studyterms)
-    return (cid, user, registration, thisUniqueNote, noteText, noteEdits, studies)
+    return (registration, studies)
-  let editByWgt = [whamlet|
-          $newline never
-          <ul .list--iconless>
-            $forall (etime,_eemail,ename,_esurname) <- noteEdits
-              <li>
-                _{MsgLastEdit} ^{editedByW SelFormatDateTime etime ename}
-        |] -- _{MsgLastEdit} ^{formatTimeW SelFormatDateTime etime} ^{nameWidget ename esurname}
 
-  ((noteRes, noteView), noteEnctype) <- runFormPost . identifyForm FIDcUserNote . renderAForm FormStandard $
+  ((regFieldRes, regFieldView), regFieldEnctype) <- lift . runFormPost . identifyForm FIDcRegField $ \csrf ->
-      aopt (annotateField editByWgt htmlField) (fslpI MsgCourseUserNote "HTML" & setTooltip MsgCourseUserNoteTooltip) (Just noteText)
-  let noteFrag :: Text
-      noteFrag = "notes"
-      noteWidget = wrapForm noteView FormSettings
-        { formMethod = POST
-        , formAction = Just . SomeRoute $ currentRoute :#: noteFrag
-        , formEncoding = noteEnctype
-        , formAttrs = []
-        , formSubmit = FormSubmit
-        , formAnchor = Just noteFrag
-        }
-  formResult noteRes $ \mbNote -> do
-    now <- liftIO getCurrentTime
-    runDB $ case mbNote of
-      Nothing -> do
-        -- must delete all edits due to foreign key constraints, which does not make sense -> refactor!
-        maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
-        deleteBy thisUniqueNote
-        addMessageI Info MsgCourseUserNoteDeleted
-      _ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return () -- no changes
-      (Just note) -> do
-        (Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
-        void . insert $ CourseUserNoteEdit dozentId now noteKey
-        addMessageI Success MsgCourseUserNoteSaved
-    redirect $ currentRoute :#: noteFrag -- reload page after post
-
-  ((regFieldRes, regFieldView), regFieldEnctype) <- runFormPost . identifyForm FIDcRegField $ \csrf ->
     let currentField :: Maybe (Maybe StudyFeaturesId)
         currentField = courseParticipantField . entityVal <$> mRegistration
      in over _2 ((toWidget csrf <>) . fvInput) <$> mreq (studyFeaturesFieldFor Nothing True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField
@@ -110,17 +83,17 @@ postCUserR tid ssh csh uCId = do
         }
   for_ mRegistration $ \(Entity pId CourseParticipant{..}) ->
     formResult regFieldRes $ \courseParticipantField' -> do
-      runDB $ do
+      lift . runDB $ do
         update pId [ CourseParticipantField =. courseParticipantField' ]
         audit $ TransactionCourseParticipantEdit cid uid
         addMessageI Success MsgCourseStudyFeatureUpdated
       redirect $ currentRoute :#: registrationFieldFrag
 
-  mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
+  mayRegister <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CAddUserR
   let regButton
         | is _Just mRegistration = BtnCourseDeregister
         | otherwise = BtnCourseRegister
-  ((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $
+  ((regButtonRes, regButtonView), regButtonEnctype) <- lift . runFormPost . identifyForm FIDcRegButton $
     if | is _Just $ courseParticipantAllocated . entityVal =<< mRegistration
          -> renderWForm FormStandard $ fmap (regButton, )
               <$  (wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip)
@@ -145,14 +118,14 @@ postCUserR tid ssh csh uCId = do
     (BtnCourseDeregister, mbReason)
       | Just (Entity _pId CourseParticipant{..}) <- mRegistration
         -> do
-          runDB $ do
+          lift . runDB $ do
             deregisterParticipant courseParticipantUser courseParticipantCourse
 
             whenIsJust mbReason $ \reason -> do
               now <- liftIO getCurrentTime
               insert_ $ AllocationDeregister courseParticipantUser (Just cid) now (Just reason)
           addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
-          redirect $ CourseR tid ssh csh CUsersR
+          redirect $ CourseR courseTerm courseSchool courseShorthand CUsersR
       | otherwise
         -> invalidArgs ["User not registered"]
     (BtnCourseRegister, _) -> do
@@ -162,7 +135,7 @@ postCUserR tid ssh csh uCId = do
             = Just featId
             | otherwise
             = Nothing
-      pId <- runDBJobs $ do
+      pId <- lift . runDBJobs $ do
         pId <- insertUnique $ CourseParticipant cid uid now field Nothing
         when (is _Just pId) $ do
           queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
@@ -177,18 +150,61 @@ postCUserR tid ssh csh uCId = do
 
   mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime
 
-  -- generate output
+  return $(widgetFile "course/user/profile")
-  let headingLong
+
-        | is _Just mRegistration
+      
-        , Just sex <- guardOn showSex =<< userSex
+courseUserNoteSection :: Entity Course -> Entity User -> MaybeT Handler Widget
-        = [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseMemberOf} #{csh} #{tid}|]
+courseUserNoteSection (Entity cid _) (Entity uid _) = do
-        | is _Just mRegistration
+  currentRoute <- MaybeT getCurrentRoute
-        = [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseMemberOf} #{csh} #{tid}|]
+
-        | Just sex <- guardOn showSex =<< userSex
+  (thisUniqueNote, noteText, noteEdits) <- lift . runDB $ do
-        = [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseAssociatedWith} #{csh} #{tid}|]
+    let thisUniqueNote = UniqueCourseUserNote uid cid
-        | otherwise
+    mbNoteEnt <- getBy thisUniqueNote
-        = [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseAssociatedWith} #{csh} #{tid}|]
+    (noteText,noteEdits) <- case mbNoteEnt of
-      headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName
+      Nothing -> return (Nothing,[])
-  siteLayout headingLong $ do
+      (Just (Entity noteKey CourseUserNote{courseUserNoteNote})) -> do
-    setTitleI headingShort
+        noteEdits <- E.select $ E.from $ \(edit `E.InnerJoin` usr) -> do
-    $(widgetFile "course-user")
+          E.on     $ edit E.^. CourseUserNoteEditUser E.==. usr E.^. UserId
+          E.where_ $ edit E.^. CourseUserNoteEditNote E.==. E.val noteKey
+          E.orderBy [E.desc $ edit E.^. CourseUserNoteEditTime]
+          E.limit 1 -- more will be shown, if changed here
+          return (edit E.^. CourseUserNoteEditTime, usr E.^. UserEmail, usr E.^. UserDisplayName, usr E.^. UserSurname)
+        return (Just courseUserNoteNote, $(unValueN 4) <$> noteEdits)
+    return (thisUniqueNote, noteText, noteEdits)
+  let editByWgt = [whamlet|
+          $newline never
+          <ul .list--iconless>
+            $forall (etime,_eemail,ename,_esurname) <- noteEdits
+              <li>
+                _{MsgLastEdit} ^{editedByW SelFormatDateTime etime ename}
+        |] -- _{MsgLastEdit} ^{formatTimeW SelFormatDateTime etime} ^{nameWidget ename esurname}
+
+  ((noteRes, noteView), noteEnctype) <- runFormPost . identifyForm FIDcUserNote . renderAForm FormStandard $
+      aopt (annotateField editByWgt htmlField) (fslpI MsgCourseUserNote "HTML" & setTooltip MsgCourseUserNoteTooltip) (Just noteText)
+  let noteFrag :: Text
+      noteFrag = "notes"
+      noteWidget = wrapForm noteView FormSettings
+        { formMethod = POST
+        , formAction = Just . SomeRoute $ currentRoute :#: noteFrag
+        , formEncoding = noteEnctype
+        , formAttrs = []
+        , formSubmit = FormSubmit
+        , formAnchor = Just noteFrag
+        }
+  formResult noteRes $ \mbNote -> do
+    now <- liftIO getCurrentTime
+    lift . runDB $ case mbNote of
+      Nothing -> do
+        -- must delete all edits due to foreign key constraints, which does not make sense -> refactor!
+        maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
+        deleteBy thisUniqueNote
+        addMessageI Info MsgCourseUserNoteDeleted
+      _ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return () -- no changes
+      (Just note) -> do
+        dozentId <- requireAuthId
+        (Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
+        void . insert $ CourseUserNoteEdit dozentId now noteKey
+        addMessageI Success MsgCourseUserNoteSaved
+    redirect $ currentRoute :#: noteFrag -- reload page after post
+
+  return $(widgetFile "course/user/note")

templates/course/user/note.hamlet

@@ -0,0 +1,3 @@
+$newline never
+<section>
+  ^{noteWidget}

templates/course/user/profile.hamlet

@@ -48,6 +48,3 @@ $newline never
         $maybe _ <- mRegistration
           <dt .deflist__dt>_{MsgCourseStudyFeature}
           <dd .deflist__dd>^{regFieldWidget}
-
-<section>
-  ^{noteWidget}