fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

feat(communication): add recipient option for course participants in at least one tutorial

Browse Source
This commit is contained in:
Sarah Vaupel 2022-02-11 23:50:48 +01:00
parent 3820eb1fab
commit 8dabb63603
6 changed files with 49 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/utils/utils/de-de-formal.msg
View File

@ -4,6 +4,7 @@ RGCourseParticipants: Kursteilnehmer:innen
RGCourseLecturers: Kursverwalter:innen
RGCourseCorrectors: Korrektor:innen
RGCourseTutors: Tutor:innen
RGCourseParticipantsInTutorial: Kursteilnehmer:innen, die in mindestens einem Tutorium angemeldet sind
RGCourseUnacceptedApplicants: Nicht akzeptierte Bewerber:innen
RecipientToggleAll: Alle/Keine
CommCourseTestSubject customSubject@Text !ident-ok: [TEST] #{customSubject}

1
messages/uniworx/utils/utils/en-eu.msg
View File

@ -4,6 +4,7 @@ RGCourseParticipants: Course participants
RGCourseLecturers: Course administrators
RGCourseCorrectors: Course correctors
RGCourseTutors: Course tutors
RGCourseParticipantsInTutorial: Course participants who are registered for at least one tutorial
RGCourseUnacceptedApplicants: Applicants not accepted
RecipientToggleAll: All/None
CommCourseTestSubject customSubject: [TEST] #{customSubject}

41
src/Handler/Course/Communication.hs
View File

@ -7,8 +7,6 @@ import Import
import Handler.Utils
import Handler.Utils.Communication
import qualified Data.Map as Map
import qualified Database.Esqueleto.Legacy as E
@ -17,8 +15,8 @@ getCCommR = postCCommR
postCCommR tid ssh csh = do
(cid, tuts, exams, sheets) <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
tuts' <- selectKeysList [TutorialCourse ==. cid] []
tuts <- forM tuts' $ \tutid -> do
tuts'' <- selectKeysList [TutorialCourse ==. cid] []
tuts' <- forM tuts'' $ \tutid -> do
cID <- encrypt tutid
return ( RGTutorialParticipants cID
, E.from $ \(user `E.InnerJoin` participant) -> do
@ -26,6 +24,18 @@ postCCommR tid ssh csh = do
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
return user
)
let
tuts | length tuts' < 2 = tuts'
| otherwise = ( RGCourseParticipantsInTutorial
, E.from $ \(user `E.InnerJoin` participant) -> do
E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
E.&&. (E.exists . E.from $ \tutParticipant -> E.where_ $
tutParticipant E.^. TutorialParticipantUser E.==. user E.^. UserId
)
return user
) : tuts'
exams' <- selectKeysList [ExamCourse ==. cid] []
exams <- forM exams' $ \examid -> do
@ -55,7 +65,7 @@ postCCommR tid ssh csh = do
, crUltDest = SomeRoute $ CourseR tid ssh csh CCommR
, crJobs = crJobsCourseCommunication cid
, crTestJobs = crTestJobsCourseCommunication cid
, crRecipients = Map.fromList $
, crRecipients =
[ ( RGCourseParticipants
, E.from $ \(user `E.InnerJoin` participant) -> do
E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser
@ -69,14 +79,6 @@ postCCommR tid ssh csh = do
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
return user
)
, ( RGCourseCorrectors
, E.from $ \user -> do
E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
E.&&. user E.^. UserId E.==. corrector E.^. SheetCorrectorUser
return user
)
, ( RGCourseTutors
, E.from $ \user -> do
E.where_ $ E.exists $ E.from $ \(tutorial `E.InnerJoin` tutor) -> do
@ -85,7 +87,16 @@ postCCommR tid ssh csh = do
E.&&. user E.^. UserId E.==. tutor E.^. TutorUser
return user
)
, ( RGCourseUnacceptedApplicants
, ( RGCourseCorrectors
, E.from $ \user -> do
E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
E.&&. user E.^. UserId E.==. corrector E.^. SheetCorrectorUser
return user
)
] ++ tuts ++ exams ++ sheets ++
[ ( RGCourseUnacceptedApplicants
, E.from $ \user -> do
E.where_ . E.exists . E.from $ \courseApplication ->
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
@ -96,7 +107,7 @@ postCCommR tid ssh csh = do
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return user
)
] ++ tuts ++ exams ++ sheets
]
, crRecipientAuth = Just $ \uid -> do
cID <- encrypt uid
evalAccessDB (CourseR tid ssh csh $ CUserR cID) False

20
src/Handler/Tutorial/Communication.hs
View File

@ -10,8 +10,6 @@ import Handler.Utils.Communication
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
import qualified Data.Map as Map
getTCommR, postTCommR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTCommR = postTCommR
@ -36,21 +34,13 @@ postTCommR tid ssh csh tutn = do
, crUltDest = SomeRoute $ CTutorialR tid ssh csh tutn TCommR
, crJobs = crJobsCourseCommunication cid
, crTestJobs = crTestJobsCourseCommunication cid
, crRecipients = Map.fromList $
, crRecipients =
[ ( RGCourseLecturers
, E.from $ \(user `E.InnerJoin` lecturer) -> do
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
return user
)
, ( RGCourseCorrectors
, E.from $ \user -> do
E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
E.&&. corrector E.^. SheetCorrectorUser E.==. user E.^. UserId
return user
)
, ( RGCourseTutors
, E.from $ \user -> do
E.where_ $ E.exists $ E.from $ \(tutorial `E.InnerJoin` tutor) -> do
@ -59,6 +49,14 @@ postTCommR tid ssh csh tutn = do
E.&&. tutor E.^. TutorUser E.==. user E.^. UserId
return user
)
, ( RGCourseCorrectors
, E.from $ \user -> do
E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
E.&&. corrector E.^. SheetCorrectorUser E.==. user E.^. UserId
return user
)
] ++ usertuts
, crRecipientAuth = Just $ \uid -> do
isTutorialUser <- E.selectExists . E.from $ \tutorialUser ->

15
src/Handler/Utils/Communication.hs
View File

@ -22,7 +22,7 @@ import qualified Data.Set as Set
import qualified Data.Conduit.Combinators as C
data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors | RGCourseUnacceptedApplicants
data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors | RGCourseParticipantsInTutorial | RGCourseUnacceptedApplicants
| RGTutorialParticipants CryptoUUIDTutorial
| RGExamRegistered CryptoUUIDExam
| RGSheetSubmittor CryptoUUIDSheet
@ -69,7 +69,7 @@ instance Button UniWorX CommunicationButton where
data CommunicationRoute = CommunicationRoute
{ crRecipients :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User)))
{ crRecipients :: [(RecipientGroup, E.SqlQuery (E.SqlExpr (Entity User)))]
, crRecipientAuth :: Maybe (UserId -> DB AuthResult) -- ^ Only resolve userids given as GET-Parameter if they fulfil this criterion
, crJobs, crTestJobs :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
, crHeading :: SomeMessage UniWorX
@ -111,7 +111,8 @@ commR CommunicationRoute{..} = do
mbCurrentRoute <- getCurrentRoute
(suggestedRecipients, chosenRecipients) <- runDB $ do
suggested <- for crRecipients $ \user -> E.select user
suggestedUsers <- for crRecipients $ \(_,user) -> E.select user
let suggested = zip (view _1 <$> crRecipients) suggestedUsers
let
decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User))
@ -127,21 +128,21 @@ commR CommunicationRoute{..} = do
let
lookupUser :: UserId -> User
lookupUser lId
= entityVal . unsafeHead . filter ((== lId) . entityKey) $ concat (Map.elems suggestedRecipients) ++ chosenRecipients
= entityVal . unsafeHead . filter ((== lId) . entityKey) $ concat (view _2 <$> suggestedRecipients) ++ chosenRecipients
let chosenRecipients' = Map.fromList $
[ ( (BoundedPosition $ RecipientGroup g, pos)
, (Right recp, recp `elem` map entityKey chosenRecipients)
)
| (g, recps) <- Map.toList suggestedRecipients
| (g, recps) <- suggestedRecipients
, (pos, recp) <- zip [0..] $ map entityKey recps
] ++
[ ( (BoundedPosition RecipientCustom, pos)
, (Right recp, True)
)
| (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ Map.elems suggestedRecipients)
| (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients)
]
activeCategories = map RecipientGroup (Map.keys suggestedRecipients) `snoc` RecipientCustom
activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom
let recipientAForm :: AForm Handler (Set (Either UserEmail UserId))
recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients')

6
templates/widgets/communication/recipientLayout.hamlet
View File

@ -16,14 +16,16 @@ $if not (null activeCategories)
_{MsgRGCourseCorrectors}
$of RecipientGroup RGCourseTutors
_{MsgRGCourseTutors}
$of RecipientGroup RGCourseParticipantsInTutorial
_{MsgRGCourseParticipantsInTutorial}
$of RecipientGroup (RGTutorialParticipants tutid)
^{rgTutorialParticipantsCaption tutid}
$of RecipientGroup RGCourseUnacceptedApplicants
_{MsgRGCourseUnacceptedApplicants}
$of RecipientGroup (RGExamRegistered eid)
^{rgExamRegisteredCaption eid}
$of RecipientGroup (RGSheetSubmittor sid)
^{rgSheetSubmittorCaption sid}
$of RecipientGroup RGCourseUnacceptedApplicants
_{MsgRGCourseUnacceptedApplicants}
$if hasContent category
<fieldset .recipient-category__fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{checkedIdent category}>