From 9850e1dd88a5371abe67fd5fb69458d7f52ea8e8 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Mon, 12 Dec 2022 04:22:22 +0100 Subject: [PATCH] feat(tutorial-users): replace study-fields column with qualifications column --- .../utils/table_column/de-de-formal.msg | 1 + messages/uniworx/utils/table_column/en-eu.msg | 1 + src/Handler/Course/Users.hs | 69 ++++++++++--------- src/Handler/Tutorial/Users.hs | 10 +-- 4 files changed, 45 insertions(+), 36 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 81e97e872..23b111979 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -71,3 +71,4 @@ TableDiffDaysTooltip: Zeitspanne nach ISO 8601. Beispiel: "P2Y3M4D" ist eine Zei TableExamOfficeLabel: Label-Name TableExamOfficeLabelStatus: Label-Farbe TableExamOfficeLabelPriority: Label-Priorität +TableQualifications: Qualifikationen diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 450a5c9a1..f00b57ea0 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -71,3 +71,4 @@ TableDiffDaysTooltip: Duration given according to ISO 8601. Example: "P2Y3M4D" i TableExamOfficeLabel: Label name TableExamOfficeLabelStatus: Label colour TableExamOfficeLabelPriority: Label priority +TableQualifications: Qualifications diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index e626c0e67..ae49a0512 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -8,7 +8,7 @@ module Handler.Course.Users ( queryUser , makeCourseUserTable , postCUsersR, getCUsersR - , colUserSex', _userStudyFeatures + , colUserSex', colUserQualifications, _userQualifications ) where import Import @@ -20,7 +20,6 @@ import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Handler.Course.Register (deregisterParticipant) -import Handler.Utils.StudyFeatures import qualified Data.Set as Set import qualified Data.Map as Map @@ -86,6 +85,7 @@ userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.L E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid return (user, participant, note E.?. CourseUserNoteId, subGroup) +type UserTableQualifications = [Entity Qualification] type UserTableData = DBRow ( Entity User , Entity CourseParticipant @@ -94,7 +94,7 @@ type UserTableData = DBRow ( Entity User , [Entity Exam] , Maybe (Entity SubmissionGroup) , Map SheetName (SheetType SqlBackendKey, Maybe Points) - , UserTableStudyFeatures + , UserTableQualifications ) instance HasEntity UserTableData User where @@ -124,8 +124,8 @@ _userSubmissionGroup = _dbrOutput . _6 . _Just _userSheets :: Lens' UserTableData (Map SheetName (SheetType SqlBackendKey, Maybe Points)) _userSheets = _dbrOutput . _7 -_userStudyFeatures :: Lens' UserTableData UserTableStudyFeatures -_userStudyFeatures = _dbrOutput . _8 +_userQualifications :: Lens' UserTableData UserTableQualifications +_userQualifications = _dbrOutput . _8 colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) @@ -173,6 +173,12 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgTableNotPassed MsgTablePassed $ Just True == gradingPassed grading' points _other -> mempty +colUserQualifications :: forall m c. IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) +colUserQualifications = sortable (Just "qualifications") (i18nCell MsgTableQualifications) $ + \(view _userQualifications -> qualis') -> + let qualis = sortOn (qualificationName . entityVal) qualis' + in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualificationCell . entityVal + data UserTableCsv = UserTableCsv { csvUserSurname :: UserSurname @@ -182,7 +188,7 @@ data UserTableCsv = UserTableCsv , csvUserMatriculation :: Maybe UserMatriculation , csvUserEPPN :: Maybe UserEduPersonPrincipalName , csvUserEmail :: UserEmail - , csvUserStudyFeatures :: UserTableStudyFeatures + , csvUserQualifications :: [QualificationName] , csvUserSubmissionGroup :: Maybe SubmissionGroupName , csvUserRegistration :: UTCTime , csvUserNote :: Maybe StoredMarkup @@ -201,7 +207,7 @@ instance Csv.ToNamedRecord UserTableCsv where , "matriculation" Csv..= csvUserMatriculation , "eduPersonPrincipalName" Csv..= csvUserEPPN , "email" Csv..= csvUserEmail - , "study-features" Csv..= csvUserStudyFeatures + , "qualifications" Csv..= CsvSemicolonList csvUserQualifications , "submission-group" Csv..= csvUserSubmissionGroup , "tutorial" Csv..= CsvSemicolonList (csvUserTutorials ^. _1) ] ++ @@ -224,7 +230,6 @@ instance CsvColumnsExplained UserTableCsv where , single "sex" MsgCsvColumnUserSex , single "matriculation" MsgCsvColumnUserMatriculation , single "email" MsgCsvColumnUserEmail - , single "study-features" MsgCsvColumnUserCourseStudyFeatures , single "submission-group" MsgCsvColumnUserSubmissionGroup , single "tutorial" MsgCsvColumnUserTutorial , single "exams" MsgCsvColumnUserExam @@ -263,7 +268,7 @@ data UserTableJson = UserTableJson , jsonUserMatriculation :: Maybe UserMatriculation , jsonUserEPPN :: Maybe UserEduPersonPrincipalName , jsonUserEmail :: UserEmail - , jsonUserStudyFeatures :: UserTableStudyFeatures + , jsonUserQualifications :: Set QualificationName , jsonUserSubmissionGroup :: Maybe SubmissionGroupName , jsonUserRegistration :: UTCTime , jsonUserNote :: Maybe Lazy.Text @@ -300,7 +305,7 @@ instance ToJSON UserTableJson where , ("matriculation" JSON..=) <$> jsonUserMatriculation , ("eduPersonPrincipalName" JSON..=) <$> jsonUserEPPN , pure $ "email" JSON..= jsonUserEmail - , ("study-features" JSON..=) <$> assertM' (views _Wrapped $ not . onull) jsonUserStudyFeatures + , ("qualifications" JSON..=) <$> assertM' (not . onull) jsonUserQualifications , ("submission-group" JSON..=) <$> jsonUserSubmissionGroup , pure $ "registration" JSON..= jsonUserRegistration , ("note" JSON..=) <$> jsonUserNote @@ -392,14 +397,17 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do , submission ) ) - feats <- courseUserStudyFeatures (participant ^. _entityVal . _courseParticipantCourse) (participant ^. _entityVal . _courseParticipantUser) + qualis <- E.select . E.from $ \(qualification `E.InnerJoin` qualificationUser) -> do + E.on $ qualification E.^. QualificationId E.==. qualificationUser E.^. QualificationUserQualification + E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val (entityKey user) + return qualification let regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials tuts = foldr (\tut@(Entity _ Tutorial{..}) -> maybe (over _1 $ cons tut) (over _2 . flip (Map.insertWith (<|>)) (Just tut)) tutorialRegGroup) ([], Map.fromSet (const Nothing) regGroups) tuts' exs = filter (\(Entity eId _) -> any ((== eId) . examRegistrationExam . entityVal) exams') exams subs = Map.fromList $ map (over (_2 . _2) (views _entityVal submissionRatingPoints <=< assertM (views _entityVal submissionRatingDone)) . over _1 E.unValue . over (_2 . _1) E.unValue) subs' - return (user, participant, userNoteId, tuts, exs, subGroup, subs, feats) + return (user, participant, userNoteId, tuts, exs, subGroup, subs, qualis) dbtColonnade = colChoices dbtSorting = mconcat [ single $ sortUserNameLink queryUser -- slower sorting through clicking name column header @@ -474,18 +482,18 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.&&. sheet E.^. SheetName E.==. E.val shn ) - , fltrRelevantStudyFeaturesTerms (to $ - \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) - , queryUser t E.^. UserId - )) - , fltrRelevantStudyFeaturesDegree (to $ - \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) - , queryUser t E.^. UserId - )) - , fltrRelevantStudyFeaturesSemester (to $ - \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) - , queryUser t E.^. UserId - )) + --, fltrRelevantStudyFeaturesTerms (to $ + -- \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) + -- , queryUser t E.^. UserId + -- )) + --, fltrRelevantStudyFeaturesDegree (to $ + -- \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) + -- , queryUser t E.^. UserId + -- )) + --, fltrRelevantStudyFeaturesSemester (to $ + -- \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) + -- , queryUser t E.^. UserId + -- )) ] where single = uncurry Map.singleton dbtFilterUI mPrev = mconcat $ @@ -497,9 +505,9 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do [ prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgTableSubmissionGroup) , prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseUserTutorial) , prismAForm (singletonFilter "exam") mPrev $ aopt textField (fslI MsgCourseUserExam) - , fltrRelevantStudyFeaturesDegreeUI mPrev - , fltrRelevantStudyFeaturesTermsUI mPrev - , fltrRelevantStudyFeaturesSemesterUI mPrev + --, fltrRelevantStudyFeaturesDegreeUI mPrev + --, fltrRelevantStudyFeaturesTermsUI mPrev + --, fltrRelevantStudyFeaturesSemesterUI mPrev ] ++ [ prismAForm (singletonFilter "has-personalised-sheet-files". maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) . optionsF $ map E.unValue personalisedSheets) (fslI MsgCourseUserHasPersonalisedSheetFilesFilter) | not $ null personalisedSheets @@ -533,12 +541,11 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do <*> view (hasUser . _userMatrikelnummer) <*> view (hasUser . _userLdapPrimaryKey) <*> view (hasUser . _userEmail) - <*> view _userStudyFeatures + <*> (over traverse (qualificationName . entityVal) <$> view _userQualifications) <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName) <*> view _userTableRegistration <*> userNote <*> (over (_2.traverse._Just) (tutorialName . entityVal) . over (_1.traverse) (tutorialName . entityVal) <$> view _userTutorials) - -- <*> (over (_2.traverse._Just) (examName . entityVal) . over (_1.traverse) (examName . entityVal) <$> view _userExams) <*> (over traverse (examName . entityVal) <$> view _userExams) <*> views _userSheets (set (mapped . _1 . mapped) ()) , dbtCsvName, dbtCsvSheetName @@ -566,7 +573,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do <*> view (hasUser . _userMatrikelnummer) <*> view (hasUser . _userLdapPrimaryKey) <*> view (hasUser . _userEmail) - <*> view _userStudyFeatures + <*> view (_userQualifications . folded . to (Set.singleton . qualificationName . entityVal)) <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName) <*> view _userTableRegistration <*> (fmap markupInput <$> userNote) @@ -636,7 +643,7 @@ postCUsersR tid ssh csh = do , guardOn showSex . cap' $ colUserSex' , pure . cap' $ colUserEmail , pure . cap' $ colUserMatriclenr - , pure . cap' $ colStudyFeatures _userStudyFeatures + , pure . cap' $ colUserQualifications , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh , guardOn hasExams . cap' $ colUserExams tid ssh csh diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index acc1ca823..c8c84c099 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -9,7 +9,6 @@ module Handler.Tutorial.Users import Import import Utils.Form --- import Utils.DB import Handler.Utils import Handler.Utils.Tutorial import Database.Persist.Sql (deleteWhereCount) @@ -53,13 +52,15 @@ postTUsersR tid ssh csh tutn = do showSex <- getShowSex (Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn + qualifications <- selectList [QualificationSchool ==. ssh] [] + let colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , pure colUserName , guardOn showSex colUserSex' , pure colUserEmail , pure colUserMatriclenr - , pure $ colStudyFeatures _userStudyFeatures + , pure colUserQualifications ] psValidator = def & defaultSortingByName @@ -68,10 +69,9 @@ postTUsersR tid ssh csh tutn = do isInTut q = E.exists . E.from $ \tutorialParticipant -> E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid - csvColChoices = flip elem ["name", "matriculation", "email", "study-features"] + csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"] cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - availableQualifications <- selectList [QualificationSchool ==. ssh] [] let qualOpt :: Entity Qualification -> Handler (Option QualificationId) qualOpt (Entity qualId qual) = do @@ -85,7 +85,7 @@ postTUsersR tid ssh csh tutn = do acts = Map.fromList [ ( TutorialUserGrantQualification , TutorialUserGrantQualificationData - <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt availableQualifications) (fslI MsgQualificationName) Nothing + <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing <*> apopt dayField (fslI MsgLmsQualificationValidUntil) Nothing ) , ( TutorialUserSendMail, pure TutorialUserSendMailData )