diff --git a/src/Foundation.hs b/src/Foundation.hs
index 8cbe2940a..878510f3d 100644
--- a/src/Foundation.hs
+++ b/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
diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs
index aef35f333..240c80cec 100644
--- a/src/Handler/Course/User.hs
+++ b/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):
- --
- -- - User is current member of course
- -- - User has submitted in course
- -- - User is member of registered group for course
- -- - 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
+ showSex <- maybe False (userShowSex . entityVal) <$> maybeAuth
+
+ (course, user@(Entity _ User{..}), registered) <- runDB $ do
+ uid <- decrypt uCId
+ course@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
user <- get404 uid
- registration <- getBy (UniqueParticipant uid cid)
- -- Abfrage Teilnehmernotiz
- let thisUniqueNote = UniqueCourseUserNote uid cid
- mbNoteEnt <- getBy thisUniqueNote
- (noteText,noteEdits) <- case mbNoteEnt of
- Nothing -> return (Nothing,[])
- (Just (Entity noteKey CourseUserNote{courseUserNoteNote})) -> do
- 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
- 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)
- -- Abfrage Studiengänge
+ registered <- existsBy $ UniqueParticipant uid cid
+
+ return (course, Entity uid user, registered)
+
+ sections <- mapM (runMaybeT . ($ user) . ($ course))
+ [ courseUserProfileSection
+ , courseUserNoteSection
+ ]
+
+ -- generate output
+ let headingLong
+ | registered
+ , Just sex <- guardOn showSex =<< userSex
+ = [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseMemberOf} #{csh} #{tid}|]
+ | 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)
- let editByWgt = [whamlet|
- $newline never
-
- $forall (etime,_eemail,ename,_esurname) <- noteEdits
- -
- _{MsgLastEdit} ^{editedByW SelFormatDateTime etime ename}
- |] -- _{MsgLastEdit} ^{formatTimeW SelFormatDateTime etime} ^{nameWidget ename esurname}
+ return (registration, studies)
- ((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
- 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 ->
+ ((regFieldRes, regFieldView), regFieldEnctype) <- lift . 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
- let headingLong
- | is _Just mRegistration
- , Just sex <- guardOn showSex =<< userSex
- = [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseMemberOf} #{csh} #{tid}|]
- | is _Just mRegistration
- = [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
- $(widgetFile "course-user")
+ return $(widgetFile "course/user/profile")
+
+
+courseUserNoteSection :: Entity Course -> Entity User -> MaybeT Handler Widget
+courseUserNoteSection (Entity cid _) (Entity uid _) = do
+ currentRoute <- MaybeT getCurrentRoute
+
+ (thisUniqueNote, noteText, noteEdits) <- lift . runDB $ do
+ let thisUniqueNote = UniqueCourseUserNote uid cid
+ mbNoteEnt <- getBy thisUniqueNote
+ (noteText,noteEdits) <- case mbNoteEnt of
+ Nothing -> return (Nothing,[])
+ (Just (Entity noteKey CourseUserNote{courseUserNoteNote})) -> do
+ 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
+ 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
+
+ $forall (etime,_eemail,ename,_esurname) <- noteEdits
+ -
+ _{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")
diff --git a/templates/course/user/note.hamlet b/templates/course/user/note.hamlet
new file mode 100644
index 000000000..d5d42d321
--- /dev/null
+++ b/templates/course/user/note.hamlet
@@ -0,0 +1,3 @@
+$newline never
+
+ ^{noteWidget}
diff --git a/templates/course-user.hamlet b/templates/course/user/profile.hamlet
similarity index 98%
rename from templates/course-user.hamlet
rename to templates/course/user/profile.hamlet
index a70589875..20fdae68f 100644
--- a/templates/course-user.hamlet
+++ b/templates/course/user/profile.hamlet
@@ -48,6 +48,3 @@ $newline never
$maybe _ <- mRegistration
- _{MsgCourseStudyFeature}
- ^{regFieldWidget}
-
-