feat(tutorial-users): replace study-fields column with qualifications column
This commit is contained in:
Sarah Vaupel
parent
fa0caba55d
commit
9850e1dd88
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 )
|
||||
|
||||
Loading…
Reference in New Issue
Block a user