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

feat(tutorial-users): replace study-fields column with qualifications column

Browse Source
This commit is contained in:
Sarah Vaupel 2022-12-12 04:22:22 +01:00
parent fa0caba55d
commit 9850e1dd88
4 changed files with 45 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -71,3 +71,4 @@ TableDiffDaysTooltip: Zeitspanne nach ISO 8601. Beispiel: "P2Y3M4D" ist eine Zei
TableExamOfficeLabel: Label-Name TableExamOfficeLabel: Label-Name
TableExamOfficeLabelStatus: Label-Farbe TableExamOfficeLabelStatus: Label-Farbe
TableExamOfficeLabelPriority: Label-Priorität TableExamOfficeLabelPriority: Label-Priorität
TableQualifications: Qualifikationen

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

@ -71,3 +71,4 @@ TableDiffDaysTooltip: Duration given according to ISO 8601. Example: "P2Y3M4D" i
TableExamOfficeLabel: Label name TableExamOfficeLabel: Label name
TableExamOfficeLabelStatus: Label colour TableExamOfficeLabelStatus: Label colour
TableExamOfficeLabelPriority: Label priority TableExamOfficeLabelPriority: Label priority
TableQualifications: Qualifications

69
src/Handler/Course/Users.hs
View File

@ -8,7 +8,7 @@ module Handler.Course.Users
( queryUser ( queryUser
, makeCourseUserTable , makeCourseUserTable
, postCUsersR, getCUsersR , postCUsersR, getCUsersR
, colUserSex', _userStudyFeatures , colUserSex', colUserQualifications, _userQualifications
) where ) where
import Import import Import
@ -20,7 +20,6 @@ import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
import Handler.Course.Register (deregisterParticipant) import Handler.Course.Register (deregisterParticipant)
import Handler.Utils.StudyFeatures
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map 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 E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
return (user, participant, note E.?. CourseUserNoteId, subGroup) return (user, participant, note E.?. CourseUserNoteId, subGroup)
type UserTableQualifications = [Entity Qualification]
type UserTableData = DBRow ( Entity User type UserTableData = DBRow ( Entity User
, Entity CourseParticipant , Entity CourseParticipant
@ -94,7 +94,7 @@ type UserTableData = DBRow ( Entity User
, [Entity Exam] , [Entity Exam]
, Maybe (Entity SubmissionGroup) , Maybe (Entity SubmissionGroup)
, Map SheetName (SheetType SqlBackendKey, Maybe Points) , Map SheetName (SheetType SqlBackendKey, Maybe Points)
, UserTableStudyFeatures , UserTableQualifications
) )
instance HasEntity UserTableData User where instance HasEntity UserTableData User where
@ -124,8 +124,8 @@ _userSubmissionGroup = _dbrOutput . _6 . _Just
_userSheets :: Lens' UserTableData (Map SheetName (SheetType SqlBackendKey, Maybe Points)) _userSheets :: Lens' UserTableData (Map SheetName (SheetType SqlBackendKey, Maybe Points))
_userSheets = _dbrOutput . _7 _userSheets = _dbrOutput . _7
_userStudyFeatures :: Lens' UserTableData UserTableStudyFeatures _userQualifications :: Lens' UserTableData UserTableQualifications
_userStudyFeatures = _dbrOutput . _8 _userQualifications = _dbrOutput . _8
colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) 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 Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgTableNotPassed MsgTablePassed $ Just True == gradingPassed grading' points
_other -> mempty _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 data UserTableCsv = UserTableCsv
{ csvUserSurname :: UserSurname { csvUserSurname :: UserSurname
@ -182,7 +188,7 @@ data UserTableCsv = UserTableCsv
, csvUserMatriculation :: Maybe UserMatriculation , csvUserMatriculation :: Maybe UserMatriculation
, csvUserEPPN :: Maybe UserEduPersonPrincipalName , csvUserEPPN :: Maybe UserEduPersonPrincipalName
, csvUserEmail :: UserEmail , csvUserEmail :: UserEmail
, csvUserStudyFeatures :: UserTableStudyFeatures , csvUserQualifications :: [QualificationName]
, csvUserSubmissionGroup :: Maybe SubmissionGroupName , csvUserSubmissionGroup :: Maybe SubmissionGroupName
, csvUserRegistration :: UTCTime , csvUserRegistration :: UTCTime
, csvUserNote :: Maybe StoredMarkup , csvUserNote :: Maybe StoredMarkup
@ -201,7 +207,7 @@ instance Csv.ToNamedRecord UserTableCsv where
, "matriculation" Csv..= csvUserMatriculation , "matriculation" Csv..= csvUserMatriculation
, "eduPersonPrincipalName" Csv..= csvUserEPPN , "eduPersonPrincipalName" Csv..= csvUserEPPN
, "email" Csv..= csvUserEmail , "email" Csv..= csvUserEmail
, "study-features" Csv..= csvUserStudyFeatures , "qualifications" Csv..= CsvSemicolonList csvUserQualifications
, "submission-group" Csv..= csvUserSubmissionGroup , "submission-group" Csv..= csvUserSubmissionGroup
, "tutorial" Csv..= CsvSemicolonList (csvUserTutorials ^. _1) , "tutorial" Csv..= CsvSemicolonList (csvUserTutorials ^. _1)
] ++ ] ++
@ -224,7 +230,6 @@ instance CsvColumnsExplained UserTableCsv where
, single "sex" MsgCsvColumnUserSex , single "sex" MsgCsvColumnUserSex
, single "matriculation" MsgCsvColumnUserMatriculation , single "matriculation" MsgCsvColumnUserMatriculation
, single "email" MsgCsvColumnUserEmail , single "email" MsgCsvColumnUserEmail
, single "study-features" MsgCsvColumnUserCourseStudyFeatures
, single "submission-group" MsgCsvColumnUserSubmissionGroup , single "submission-group" MsgCsvColumnUserSubmissionGroup
, single "tutorial" MsgCsvColumnUserTutorial , single "tutorial" MsgCsvColumnUserTutorial
, single "exams" MsgCsvColumnUserExam , single "exams" MsgCsvColumnUserExam
@ -263,7 +268,7 @@ data UserTableJson = UserTableJson
, jsonUserMatriculation :: Maybe UserMatriculation , jsonUserMatriculation :: Maybe UserMatriculation
, jsonUserEPPN :: Maybe UserEduPersonPrincipalName , jsonUserEPPN :: Maybe UserEduPersonPrincipalName
, jsonUserEmail :: UserEmail , jsonUserEmail :: UserEmail
, jsonUserStudyFeatures :: UserTableStudyFeatures , jsonUserQualifications :: Set QualificationName
, jsonUserSubmissionGroup :: Maybe SubmissionGroupName , jsonUserSubmissionGroup :: Maybe SubmissionGroupName
, jsonUserRegistration :: UTCTime , jsonUserRegistration :: UTCTime
, jsonUserNote :: Maybe Lazy.Text , jsonUserNote :: Maybe Lazy.Text
@ -300,7 +305,7 @@ instance ToJSON UserTableJson where
, ("matriculation" JSON..=) <$> jsonUserMatriculation , ("matriculation" JSON..=) <$> jsonUserMatriculation
, ("eduPersonPrincipalName" JSON..=) <$> jsonUserEPPN , ("eduPersonPrincipalName" JSON..=) <$> jsonUserEPPN
, pure $ "email" JSON..= jsonUserEmail , pure $ "email" JSON..= jsonUserEmail
, ("study-features" JSON..=) <$> assertM' (views _Wrapped $ not . onull) jsonUserStudyFeatures , ("qualifications" JSON..=) <$> assertM' (not . onull) jsonUserQualifications
, ("submission-group" JSON..=) <$> jsonUserSubmissionGroup , ("submission-group" JSON..=) <$> jsonUserSubmissionGroup
, pure $ "registration" JSON..= jsonUserRegistration , pure $ "registration" JSON..= jsonUserRegistration
, ("note" JSON..=) <$> jsonUserNote , ("note" JSON..=) <$> jsonUserNote
@ -392,14 +397,17 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
, submission , 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 let
regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials
tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') 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' 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 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' 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 dbtColonnade = colChoices
dbtSorting = mconcat dbtSorting = mconcat
[ single $ sortUserNameLink queryUser -- slower sorting through clicking name column header [ 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.where_ $ sheet E.^. SheetCourse E.==. E.val cid
E.&&. sheet E.^. SheetName E.==. E.val shn E.&&. sheet E.^. SheetName E.==. E.val shn
) )
, fltrRelevantStudyFeaturesTerms (to $ --, fltrRelevantStudyFeaturesTerms (to $
\t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) -- \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm)
, queryUser t E.^. UserId -- , queryUser t E.^. UserId
)) -- ))
, fltrRelevantStudyFeaturesDegree (to $ --, fltrRelevantStudyFeaturesDegree (to $
\t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) -- \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm)
, queryUser t E.^. UserId -- , queryUser t E.^. UserId
)) -- ))
, fltrRelevantStudyFeaturesSemester (to $ --, fltrRelevantStudyFeaturesSemester (to $
\t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm) -- \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm)
, queryUser t E.^. UserId -- , queryUser t E.^. UserId
)) -- ))
] ]
where single = uncurry Map.singleton where single = uncurry Map.singleton
dbtFilterUI mPrev = mconcat $ 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 "submission-group") mPrev $ aopt textField (fslI MsgTableSubmissionGroup)
, prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseUserTutorial) , prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseUserTutorial)
, prismAForm (singletonFilter "exam") mPrev $ aopt textField (fslI MsgCourseUserExam) , prismAForm (singletonFilter "exam") mPrev $ aopt textField (fslI MsgCourseUserExam)
, fltrRelevantStudyFeaturesDegreeUI mPrev --, fltrRelevantStudyFeaturesDegreeUI mPrev
, fltrRelevantStudyFeaturesTermsUI mPrev --, fltrRelevantStudyFeaturesTermsUI mPrev
, fltrRelevantStudyFeaturesSemesterUI mPrev --, fltrRelevantStudyFeaturesSemesterUI mPrev
] ++ ] ++
[ prismAForm (singletonFilter "has-personalised-sheet-files". maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) . optionsF $ map E.unValue personalisedSheets) (fslI MsgCourseUserHasPersonalisedSheetFilesFilter) [ prismAForm (singletonFilter "has-personalised-sheet-files". maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) . optionsF $ map E.unValue personalisedSheets) (fslI MsgCourseUserHasPersonalisedSheetFilesFilter)
| not $ null personalisedSheets | not $ null personalisedSheets
@ -533,12 +541,11 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
<*> view (hasUser . _userMatrikelnummer) <*> view (hasUser . _userMatrikelnummer)
<*> view (hasUser . _userLdapPrimaryKey) <*> view (hasUser . _userLdapPrimaryKey)
<*> view (hasUser . _userEmail) <*> view (hasUser . _userEmail)
<*> view _userStudyFeatures <*> (over traverse (qualificationName . entityVal) <$> view _userQualifications)
<*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName) <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
<*> view _userTableRegistration <*> view _userTableRegistration
<*> userNote <*> userNote
<*> (over (_2.traverse._Just) (tutorialName . entityVal) . over (_1.traverse) (tutorialName . entityVal) <$> view _userTutorials) <*> (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) <*> (over traverse (examName . entityVal) <$> view _userExams)
<*> views _userSheets (set (mapped . _1 . mapped) ()) <*> views _userSheets (set (mapped . _1 . mapped) ())
, dbtCsvName, dbtCsvSheetName , dbtCsvName, dbtCsvSheetName
@ -566,7 +573,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
<*> view (hasUser . _userMatrikelnummer) <*> view (hasUser . _userMatrikelnummer)
<*> view (hasUser . _userLdapPrimaryKey) <*> view (hasUser . _userLdapPrimaryKey)
<*> view (hasUser . _userEmail) <*> view (hasUser . _userEmail)
<*> view _userStudyFeatures <*> view (_userQualifications . folded . to (Set.singleton . qualificationName . entityVal))
<*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName) <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
<*> view _userTableRegistration <*> view _userTableRegistration
<*> (fmap markupInput <$> userNote) <*> (fmap markupInput <$> userNote)
@ -636,7 +643,7 @@ postCUsersR tid ssh csh = do
, guardOn showSex . cap' $ colUserSex' , guardOn showSex . cap' $ colUserSex'
, pure . cap' $ colUserEmail , pure . cap' $ colUserEmail
, pure . cap' $ colUserMatriclenr , pure . cap' $ colUserMatriclenr
, pure . cap' $ colStudyFeatures _userStudyFeatures , pure . cap' $ colUserQualifications
, guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup
, guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh
, guardOn hasExams . cap' $ colUserExams tid ssh csh , guardOn hasExams . cap' $ colUserExams tid ssh csh

10
src/Handler/Tutorial/Users.hs
View File

@ -9,7 +9,6 @@ module Handler.Tutorial.Users
import Import import Import
import Utils.Form import Utils.Form
-- import Utils.DB
import Handler.Utils import Handler.Utils
import Handler.Utils.Tutorial import Handler.Utils.Tutorial
import Database.Persist.Sql (deleteWhereCount) import Database.Persist.Sql (deleteWhereCount)
@ -53,13 +52,15 @@ postTUsersR tid ssh csh tutn = do
showSex <- getShowSex showSex <- getShowSex
(Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do (Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do
tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
qualifications <- selectList [QualificationSchool ==. ssh] []
let colChoices = mconcat $ catMaybes let colChoices = mconcat $ catMaybes
[ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, pure colUserName , pure colUserName
, guardOn showSex colUserSex' , guardOn showSex colUserSex'
, pure colUserEmail , pure colUserEmail
, pure colUserMatriclenr , pure colUserMatriclenr
, pure $ colStudyFeatures _userStudyFeatures , pure colUserQualifications
] ]
psValidator = def psValidator = def
& defaultSortingByName & defaultSortingByName
@ -68,10 +69,9 @@ postTUsersR tid ssh csh tutn = do
isInTut q = E.exists . E.from $ \tutorialParticipant -> isInTut q = E.exists . E.from $ \tutorialParticipant ->
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid 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 cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
availableQualifications <- selectList [QualificationSchool ==. ssh] []
let let
qualOpt :: Entity Qualification -> Handler (Option QualificationId) qualOpt :: Entity Qualification -> Handler (Option QualificationId)
qualOpt (Entity qualId qual) = do qualOpt (Entity qualId qual) = do
@ -85,7 +85,7 @@ postTUsersR tid ssh csh tutn = do
acts = Map.fromList acts = Map.fromList
[ ( TutorialUserGrantQualification [ ( TutorialUserGrantQualification
, TutorialUserGrantQualificationData , 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 <*> apopt dayField (fslI MsgLmsQualificationValidUntil) Nothing
) )
, ( TutorialUserSendMail, pure TutorialUserSendMailData ) , ( TutorialUserSendMail, pure TutorialUserSendMailData )