From 8e1b9b9abae0c794ce12f10e5f75f410f903d927 Mon Sep 17 00:00:00 2001 From: Luca Maio Date: Tue, 8 Feb 2022 23:43:32 +0100 Subject: [PATCH 01/10] feat(courses): add search bars for shorthands and titles --- .../uniworx/categories/courses/courses/de-de-formal.msg | 4 +++- messages/uniworx/categories/courses/courses/en-eu.msg | 4 +++- src/Handler/Course/List.hs | 8 ++++++++ 3 files changed, 14 insertions(+), 2 deletions(-) diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index 2e1880882..9d844abc2 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -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 \ No newline at end of file +CourseAdministrator: Kursadministrator:in diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index c4eda4efc..93ebd52a5 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -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 \ No newline at end of file +CourseAdministrator: Course administrator diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index 02c5f7b43..c7ea11753 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -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)) From b294b1cfc4bab4b5ec5247d37097873748759727 Mon Sep 17 00:00:00 2001 From: Luca Maio Date: Wed, 9 Feb 2022 11:34:09 +0100 Subject: [PATCH 02/10] fix(exams): exam results of non-registered users now show correctly --- src/Handler/ExamOffice/Exam.hs | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index cde8a0015..69a32fd3f 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -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) From 8dabb63603341c7e2d7dadb95deeb77f864c14a0 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 11 Feb 2022 23:50:48 +0100 Subject: [PATCH 03/10] feat(communication): add recipient option for course participants in at least one tutorial --- messages/uniworx/utils/utils/de-de-formal.msg | 1 + messages/uniworx/utils/utils/en-eu.msg | 1 + src/Handler/Course/Communication.hs | 41 ++++++++++++------- src/Handler/Tutorial/Communication.hs | 20 ++++----- src/Handler/Utils/Communication.hs | 15 +++---- .../communication/recipientLayout.hamlet | 6 ++- 6 files changed, 49 insertions(+), 35 deletions(-) diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 615126c14..1e98b1417 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -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} diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 6f1ecad76..db6338b4c 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -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} diff --git a/src/Handler/Course/Communication.hs b/src/Handler/Course/Communication.hs index eac35ee83..cb9e762d2 100644 --- a/src/Handler/Course/Communication.hs +++ b/src/Handler/Course/Communication.hs @@ -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 diff --git a/src/Handler/Tutorial/Communication.hs b/src/Handler/Tutorial/Communication.hs index c01464eec..84670801e 100644 --- a/src/Handler/Tutorial/Communication.hs +++ b/src/Handler/Tutorial/Communication.hs @@ -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 -> diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 39e1681ce..81b266fa6 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -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') diff --git a/templates/widgets/communication/recipientLayout.hamlet b/templates/widgets/communication/recipientLayout.hamlet index ad63a7eb7..b925e632e 100644 --- a/templates/widgets/communication/recipientLayout.hamlet +++ b/templates/widgets/communication/recipientLayout.hamlet @@ -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
From 0fe4d9f5f5b4059400a4f2c18556fa4fc2a5b82b Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 8 Feb 2022 21:18:48 +0100 Subject: [PATCH 04/10] refactor(model): restructure common types --- src/Model/Types/Common.hs | 76 ++++++++++++++++++++------------------- 1 file changed, 40 insertions(+), 36 deletions(-) diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index 18e3e6b38..8429dfc6b 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -13,49 +13,53 @@ import Import.NoModel import qualified Yesod.Auth.Util.PasswordStore as PWStore -type Count = Sum Integer -type Points = Centi +type Count = Sum Integer +type Points = Centi -type Email = Text +type Email = Text -type UserTitle = Text -type UserFirstName = Text -type UserSurname = Text -type UserDisplayName = Text -type UserMatriculation = Text +type UserTitle = Text +type UserFirstName = Text +type UserSurname = Text +type UserDisplayName = Text +type UserMatriculation = Text +type UserEmail = CI Email +type UserIdent = CI Text -type StudyDegreeName = Text -type StudyDegreeShorthand = Text -type StudyDegreeKey = Int -type StudyTermsName = Text -type StudyTermsShorthand = Text -type StudyTermsKey = Int -type StudySubTermsKey = Int +type StudyDegreeName = Text +type StudyDegreeShorthand = Text +type StudyDegreeKey = Int +type StudyTermsName = Text +type StudyTermsShorthand = Text +type StudyTermsKey = Int +type StudySubTermsKey = Int -type SchoolName = CI Text -type SchoolShorthand = CI Text -type CourseName = CI Text -type CourseShorthand = CI Text -type SheetName = CI Text -type MaterialName = CI Text -type UserEmail = CI Email -type UserIdent = CI Text -type TutorialName = CI Text -type ExamName = CI Text -type ExamPartName = CI Text -type ExamOccurrenceName = CI Text -type AllocationName = CI Text -type AllocationShorthand = CI Text +type SchoolName = CI Text +type SchoolShorthand = CI Text -type SubmissionGroupName = CI Text +type CourseName = CI Text +type CourseShorthand = CI Text +type MaterialName = CI Text +type TutorialName = CI Text +type SheetName = CI Text +type SubmissionGroupName = CI Text -type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString -type InstanceId = UUID -type ClusterId = UUID -type TokenId = UUID -type TermCandidateIncidence = UUID +type ExamName = CI Text +type ExamPartName = CI Text +type ExamOccurrenceName = CI Text -type SessionFileReference = Digest SHA3_256 +type AllocationName = CI Text +type AllocationShorthand = CI Text + +type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString + +type InstanceId = UUID +type ClusterId = UUID +type TokenId = UUID + +type TermCandidateIncidence = UUID + +type SessionFileReference = Digest SHA3_256 type WorkflowDefinitionName = CI Text type WorkflowInstanceName = CI Text From 022a4db05a078a4d2804ca4bac7782db7a51a666 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 8 Feb 2022 21:40:29 +0100 Subject: [PATCH 05/10] chore(model): add ePPN type --- src/Model/Types/Common.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index 8429dfc6b..91fb5996e 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -18,13 +18,14 @@ type Points = Centi type Email = Text -type UserTitle = Text -type UserFirstName = Text -type UserSurname = Text -type UserDisplayName = Text -type UserMatriculation = Text -type UserEmail = CI Email -type UserIdent = CI Text +type UserTitle = Text +type UserFirstName = Text +type UserSurname = Text +type UserDisplayName = Text +type UserIdent = CI Text +type UserMatriculation = Text +type UserEmail = CI Email +type UserEduPersonPrincipalName = CI Email type StudyDegreeName = Text type StudyDegreeShorthand = Text From 14c2f6d82d8e6d7d472cfb200d8d491fc0e964fa Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 8 Feb 2022 22:17:20 +0100 Subject: [PATCH 06/10] chore(model): eppn as Text, move to User Types --- src/Model/Types/Common.hs | 15 +++++++-------- src/Model/Types/User.hs | 3 +++ 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index 91fb5996e..17eb6bc3d 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -18,14 +18,13 @@ type Points = Centi type Email = Text -type UserTitle = Text -type UserFirstName = Text -type UserSurname = Text -type UserDisplayName = Text -type UserIdent = CI Text -type UserMatriculation = Text -type UserEmail = CI Email -type UserEduPersonPrincipalName = CI Email +type UserTitle = Text +type UserFirstName = Text +type UserSurname = Text +type UserDisplayName = Text +type UserIdent = CI Text +type UserMatriculation = Text +type UserEmail = CI Email type StudyDegreeName = Text type StudyDegreeShorthand = Text diff --git a/src/Model/Types/User.hs b/src/Model/Types/User.hs index 6e1b966a4..4f99c37de 100644 --- a/src/Model/Types/User.hs +++ b/src/Model/Types/User.hs @@ -4,6 +4,9 @@ import Import.NoModel import Model.Types.TH.PathPiece +type UserEduPersonPrincipalName = CI Text + + data SystemFunction = SystemExamOffice | SystemFaculty From 3c797039cc0784a2831167c11ed1b7bb8ff78daa Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Tue, 8 Feb 2022 23:08:47 +0100 Subject: [PATCH 07/10] feat(course-users): export eppn to csv and json --- models/users.model | 2 +- src/Handler/Course/Users.hs | 18 ++++++++++++------ src/Model/Types/User.hs | 2 +- 3 files changed, 14 insertions(+), 8 deletions(-) diff --git a/models/users.model b/models/users.model index 80846e952..6269df759 100644 --- a/models/users.model +++ b/models/users.model @@ -17,7 +17,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create lastAuthentication UTCTime Maybe -- last login date created UTCTime default=now() lastLdapSynchronisation UTCTime Maybe - ldapPrimaryKey Text Maybe + ldapPrimaryKey UserEduPersonPrincipalName Maybe tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null) matrikelnummer UserMatriculation Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...) firstName Text -- For export in tables, pre-split firstName from displayName diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 0d25a488b..37cb6ee00 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -176,6 +176,7 @@ data UserTableCsv = UserTableCsv , csvUserName :: UserDisplayName , csvUserSex :: Maybe Sex , csvUserMatriculation :: Maybe UserMatriculation + , csvUserEPPN :: Maybe UserEduPersonPrincipalName , csvUserEmail :: UserEmail , csvUserStudyFeatures :: UserTableStudyFeatures , csvUserSubmissionGroup :: Maybe SubmissionGroupName @@ -194,6 +195,7 @@ instance Csv.ToNamedRecord UserTableCsv where , "name" Csv..= csvUserName , "sex" Csv..= csvUserSex , "matriculation" Csv..= csvUserMatriculation + , "eduPersonPrincipalName" Csv..= csvUserEPPN , "email" Csv..= csvUserEmail , "study-features" Csv..= csvUserStudyFeatures , "submission-group" Csv..= csvUserSubmissionGroup @@ -239,7 +241,7 @@ userTableCsvHeader :: Bool -> [Entity Tutorial] -> [Entity Sheet] -> UserCsvExpo userTableCsvHeader showSex tuts sheets UserCsvExportData{..} = Csv.header $ [ "surname", "first-name", "name" ] ++ [ "sex" | showSex ] ++ - [ "matriculation", "email", "study-features"] ++ + [ "matriculation", "eduPersonPrincipalName", "email", "study-features"] ++ [ "tutorial" | hasEmptyRegGroup ] ++ map (encodeUtf8 . CI.foldedCase) regGroups ++ [ "exams", "registration" ] ++ @@ -255,6 +257,7 @@ data UserTableJson = UserTableJson , jsonUserName :: UserDisplayName , jsonUserSex :: Maybe (Maybe Sex) , jsonUserMatriculation :: Maybe UserMatriculation + , jsonUserEPPN :: Maybe UserEduPersonPrincipalName , jsonUserEmail :: UserEmail , jsonUserStudyFeatures :: UserTableStudyFeatures , jsonUserSubmissionGroup :: Maybe SubmissionGroupName @@ -291,6 +294,7 @@ instance ToJSON UserTableJson where , pure $ "name" JSON..= jsonUserName , ("sex" JSON..=) <$> jsonUserSex , ("matriculation" JSON..=) <$> jsonUserMatriculation + , ("eduPersonPrincipalName" JSON..=) <$> jsonUserEPPN , pure $ "email" JSON..= jsonUserEmail , ("study-features" JSON..=) <$> assertM' (views _Wrapped $ not . onull) jsonUserStudyFeatures , ("submission-group" JSON..=) <$> jsonUserSubmissionGroup @@ -523,6 +527,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do <*> view (hasUser . _userDisplayName) <*> view (hasUser . _userSex) <*> view (hasUser . _userMatrikelnummer) + <*> view (hasUser . _userLdapPrimaryKey) <*> view (hasUser . _userEmail) <*> view _userStudyFeatures <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName) @@ -550,12 +555,13 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do repUserJson = C.foldMapM $ \(E.Value uid, res) -> Map.singleton <$> encrypt uid <*> mkUserTableJson res where mkUserTableJson res' = flip runReaderT res' $ UserTableJson - <$> view (hasUser . _userSurname) - <*> view (hasUser . _userFirstName) - <*> view (hasUser . _userDisplayName) + <$> view (hasUser . _userSurname) + <*> view (hasUser . _userFirstName) + <*> view (hasUser . _userDisplayName) <*> views (hasUser . _userSex) (guardOn showSex) - <*> view (hasUser . _userMatrikelnummer) - <*> view (hasUser . _userEmail) + <*> view (hasUser . _userMatrikelnummer) + <*> view (hasUser . _userLdapPrimaryKey) + <*> view (hasUser . _userEmail) <*> view _userStudyFeatures <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName) <*> view _userTableRegistration diff --git a/src/Model/Types/User.hs b/src/Model/Types/User.hs index 4f99c37de..1d32d639a 100644 --- a/src/Model/Types/User.hs +++ b/src/Model/Types/User.hs @@ -4,7 +4,7 @@ import Import.NoModel import Model.Types.TH.PathPiece -type UserEduPersonPrincipalName = CI Text +type UserEduPersonPrincipalName = Text data SystemFunction From ff1fe20efed340529a3a12858d82d668e5fe2e85 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 11 Feb 2022 15:49:21 +0100 Subject: [PATCH 08/10] feat(exam-users): export eppn for exam users --- src/Handler/Exam/Users.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 5d20a3587..9b36b676c 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -183,6 +183,7 @@ data ExamUserTableCsv = ExamUserTableCsv , csvEUserFirstName :: Maybe Text , csvEUserName :: Maybe Text , csvEUserMatriculation :: Maybe Text + , csvEUserEPPN :: Maybe UserEduPersonPrincipalName , csvEUserStudyFeatures :: UserTableStudyFeatures , csvEUserOccurrence :: Maybe (CI Text) , csvEUserExercisePoints :: Maybe (Maybe Points) @@ -203,6 +204,7 @@ instance ToNamedRecord ExamUserTableCsv where , "first-name" Csv..= csvEUserFirstName , "name" Csv..= csvEUserName , "matriculation" Csv..= csvEUserMatriculation + , "eduPersonPrincipalName" Csv..= csvEUserEPPN , "study-features" Csv..= csvEUserStudyFeatures , "occurrence" Csv..= csvEUserOccurrence ] ++ catMaybes @@ -228,6 +230,7 @@ instance FromNamedRecord ExamUserTableCsv where <*> csv .:?? "first-name" <*> csv .:?? "name" <*> csv .:?? "matriculation" + <*> csv .:?? "eduPersonPrincipalName" <*> pure mempty <*> csv .:?? "occurrence" <*> fmap Just (csv .:?? "exercise-points") @@ -270,7 +273,7 @@ examUserTableCsvHeader :: ( MonoFoldable mono => SheetGradeSummary -> Bool -> mono -> Csv.Header examUserTableCsvHeader allBoni doBonus pNames = Csv.header $ [ "surname", "first-name", "name" - , "matriculation" + , "matriculation", "eduPersonPrincipalName" , "study-features" , "course-note" , "occurrence" @@ -608,6 +611,7 @@ postEUsersR tid ssh csh examn = do <*> view (resultUser . _entityVal . _userFirstName . to Just) <*> view (resultUser . _entityVal . _userDisplayName . to Just) <*> view (resultUser . _entityVal . _userMatrikelnummer) + <*> view (resultUser . _entityVal . _userLdapPrimaryKey) <*> view resultStudyFeatures <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) <*> fmap (bool (const Nothing) Just showPoints) (preview $ resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPoints . _Wrapped) From ecb4ff449f96ae6bb61506bd482dedfafb99530b Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 11 Feb 2022 19:20:15 +0100 Subject: [PATCH 09/10] chore(guessuser): allow resolving user by eppn --- src/Handler/Utils/Users.hs | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index f851d4fc9..06b3c80ac 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -45,10 +45,16 @@ computeUserAuthenticationDigest = hashlazy . JSON.encode data GuessUserInfo - = GuessUserMatrikelnummer { guessUserMatrikelnummer :: UserMatriculation } - | GuessUserDisplayName { guessUserDisplayName :: UserDisplayName } - | GuessUserSurname { guessUserSurname :: UserSurname } - | GuessUserFirstName { guessUserFirstName :: UserFirstName } + = GuessUserMatrikelnummer + { guessUserMatrikelnummer :: UserMatriculation } + | GuessUserEduPersonPrincipalName + { guessUserEduPersonPrincipalName :: UserEduPersonPrincipalName } + | GuessUserDisplayName + { guessUserDisplayName :: UserDisplayName } + | GuessUserSurname + { guessUserSurname :: UserSurname } + | GuessUserFirstName + { guessUserFirstName :: UserFirstName } deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Binary GuessUserInfo @@ -93,10 +99,11 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y toSql user pl = bool id E.not_ (is _PLNegated pl) $ case pl ^. _plVar of - GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation') - GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName' - GuessUserSurname userSurname' -> user E.^. UserSurname `containsAsSet` userSurname' - GuessUserFirstName userFirstName' -> user E.^. UserFirstName `containsAsSet` userFirstName' + GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation') + GuessUserEduPersonPrincipalName userEPPN' -> user E.^. UserLdapPrimaryKey E.==. E.val (Just userEPPN') + GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName' + GuessUserSurname userSurname' -> user E.^. UserSurname `containsAsSet` userSurname' + GuessUserFirstName userFirstName' -> user E.^. UserFirstName `containsAsSet` userFirstName' go didLdap = do let retrieveUsers = E.select . E.from $ \user -> do From 6a041dc4c9c6ae62c7c7f1641eeb2f5417f32b8d Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 11 Feb 2022 19:20:54 +0100 Subject: [PATCH 10/10] feat(exam-users): allow resolving exam users by eppn on csv-import --- src/Handler/Exam/Users.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 9b36b676c..5887d90fe 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -937,6 +937,7 @@ postEUsersR tid ssh csh examn = do guessUser' ExamUserTableCsv{..} = do let criteria = PredDNF . maybe Set.empty Set.singleton . fromNullable . Set.fromList . fmap PLVariable $ catMaybes [ GuessUserMatrikelnummer <$> csvEUserMatriculation + , GuessUserEduPersonPrincipalName <$> csvEUserEPPN , GuessUserDisplayName <$> csvEUserName , GuessUserSurname <$> csvEUserSurname , GuessUserFirstName <$> csvEUserFirstName