Merge branch 'gate' of gitlab2.rz.ifi.lmu.de:uni2work/uni2work into gate
This commit is contained in:
Sarah Vaupel
commit
afddbb0bee
@ -4,6 +4,8 @@ FilterTerm !ident-ok: Semester
|
||||
FilterCourseSchoolShort: Institut
|
||||
FilterRegistered: Angemeldet
|
||||
FilterCourseSearch: Volltext-Suche
|
||||
FilterCourseSearchShorthand: Kürzel-Suche
|
||||
FilterCourseSearchTitle: Titel-Suche
|
||||
FilterCourseRegistered: Registriert
|
||||
FilterCourseRegisterOpen: Anmeldung möglich
|
||||
FilterCourseAllocation: Zentralanmeldung
|
||||
@ -279,4 +281,4 @@ LecturerInvitationAccepted lType@Text csh@CourseShorthand: Sie wurden als #{lTyp
|
||||
CourseExamRegistrationTime: Angemeldet seit
|
||||
CourseParticipantStateIsActiveFilter: Ansicht
|
||||
CourseApply: Zum Kurs bewerben
|
||||
CourseAdministrator: Kursadministrator:in
|
||||
CourseAdministrator: Kursadministrator:in
|
||||
|
||||
@ -4,6 +4,8 @@ FilterTerm: Semester
|
||||
FilterCourseSchoolShort: Department
|
||||
FilterRegistered: Enrolled
|
||||
FilterCourseSearch: Text search
|
||||
FilterCourseSearchShorthand: Shorthand search
|
||||
FilterCourseSearchTitle: Title search
|
||||
FilterCourseRegistered: Registered
|
||||
FilterCourseRegisterOpen: Enrolment is allowed
|
||||
FilterCourseAllocation: Central allocation
|
||||
@ -278,4 +280,4 @@ LecturerInvitationAccepted lType csh: You were registered as #{lType} for #{csh}
|
||||
CourseExamRegistrationTime: Registered since
|
||||
CourseParticipantStateIsActiveFilter: View
|
||||
CourseApply: Apply for course
|
||||
CourseAdministrator: Course administrator
|
||||
CourseAdministrator: Course administrator
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -253,6 +253,12 @@ makeCourseTable colChoices psValidator' = do
|
||||
Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
|
||||
E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
|
||||
E.||. (E.maybe (E.val mempty) (E.castString . esqueletoMarkupOutput) (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
|
||||
, singletonMap "search-shorthand" . FilterColumn $ \(view queryCourse -> course) criterion -> case getLast (criterion :: Last Text) of
|
||||
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
Just needle -> (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
|
||||
, singletonMap "search-title" . FilterColumn $ \(view queryCourse -> course) criterion -> case getLast (criterion :: Last Text) of
|
||||
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
|
||||
, singletonMap "allocation" . FilterColumn $ \row (criteria :: Set AllocationSearch) -> if
|
||||
| Set.null criteria -> E.true
|
||||
| otherwise -> flip E.any criteria $ \case
|
||||
@ -267,6 +273,8 @@ makeCourseTable colChoices psValidator' = do
|
||||
, pure $ prismAForm (singletonFilter "schoolshort" . maybePrism (_PathPiece . from _SchoolId)) mPrev $ aopt (hoistField lift schoolField) (fslI MsgTableCourseSchool)
|
||||
, pure $ prismAForm (singletonFilter "lecturer") mPrev $ aopt textField (fslI MsgCourseLecturer)
|
||||
, pure $ prismAForm (singletonFilter "search") mPrev $ aopt textField (fslI MsgFilterCourseSearch)
|
||||
, pure $ prismAForm (singletonFilter "search-shorthand") mPrev $ aopt textField (fslI MsgFilterCourseSearchShorthand)
|
||||
, pure $ prismAForm (singletonFilter "search-title") mPrev $ aopt textField (fslI MsgFilterCourseSearchTitle)
|
||||
, pure $ prismAForm (singletonFilter "openregistration" . maybePrism _PathPiece) mPrev $ fmap (\x -> if isJust x && not (fromJust x) then Nothing else x) . aopt checkBoxField (fslI MsgFilterCourseRegisterOpen)
|
||||
, guardOn (is _Just muid)
|
||||
$ prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterCourseRegistered))
|
||||
|
||||
@ -293,9 +293,15 @@ postEGradesR tid ssh csh examn = do
|
||||
isSynced <- view . queryIsSynced $ E.val uid
|
||||
|
||||
lift $ do
|
||||
E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
|
||||
E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
|
||||
E.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
|
||||
E.on $ E.maybe E.true (\cCourse ->
|
||||
cCourse E.==. E.val examCourse
|
||||
) (courseParticipant E.?. CourseParticipantCourse)
|
||||
E.&&. E.maybe E.true (\cUser ->
|
||||
cUser E.==. user E.^. UserId
|
||||
) (courseParticipant E.?. CourseParticipantUser)
|
||||
E.&&. E.maybe E.true (\cState ->
|
||||
cState E.==. E.val CourseParticipantActive
|
||||
) (courseParticipant E.?. CourseParticipantState)
|
||||
E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
|
||||
E.&&. occurrence E.?. ExamOccurrenceId E.==. E.joinV (examRegistration E.?. ExamRegistrationOccurrence)
|
||||
E.on $ examRegistration E.?. ExamRegistrationUser E.==. E.just (user E.^. UserId)
|
||||
|
||||
@ -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 ->
|
||||
|
||||
@ -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')
|
||||
|
||||
@ -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}>
|
||||
|
||||
Reference in New Issue
Block a user