fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(course-user): modularize

Browse Source
This commit is contained in:
Gregor Kleen 2020-04-16 09:26:37 +02:00
parent 7540a4fe5f
commit 0b3c88407b
4 changed files with 132 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
src/Foundation.hs
View File

@ -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

192
src/Handler/Course/User.hs
View File

@ -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
<ul .list--iconless>
$forall (etime,_eemail,ename,_esurname) <- noteEdits
<li>
_{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
<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")

3
templates/course/user/note.hamlet Normal file
View File

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

3
templates/course-user.hamlet → templates/course/user/profile.hamlet
View File

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