From ba8bcc5436c67e5bea61d17fc67da9d44a97bdf0 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 27 Mar 2023 17:51:34 +0000 Subject: [PATCH] chore(tutorial): show user qualification info --- models/courses.model | 2 +- src/Handler/Admin.hs | 20 +++++------------- src/Handler/Course/Show.hs | 2 +- src/Handler/Course/Users.hs | 36 +++++++++++++++++++++++++------- src/Handler/Tutorial/Users.hs | 3 ++- src/Handler/Utils/Table/Cells.hs | 7 +++++++ src/Utils/Lens.hs | 6 ++++++ 7 files changed, 50 insertions(+), 26 deletions(-) diff --git a/models/courses.model b/models/courses.model index 0d278f295..95fb7cf60 100644 --- a/models/courses.model +++ b/models/courses.model @@ -94,6 +94,6 @@ CourseUserExamOfficeOptOut CourseQualification course CourseId qualification QualificationId - sortOrder Int default=0 + sortOrder Int default=0 --TODO: not yet used in Handler.Course.Users.makeCourseUserTable UniqueCourseQualification course qualification deriving Generic \ No newline at end of file diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 9749f3004..077f197f5 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -23,7 +23,8 @@ import qualified Database.Esqueleto.Utils as E import Handler.Utils.DateTime import Handler.Utils.Avs import Handler.Utils.Widgets -import Handler.Utils.Users +import Handler.Utils.Users +import Handler.Utils.Qualification import Handler.Admin.Test as Handler.Admin import Handler.Admin.ErrorMessage as Handler.Admin @@ -170,14 +171,6 @@ allDriversHaveAvsId :: Day -> DB Bool -- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId -qIsValid :: E.SqlExpr (Entity QualificationUser) -> Day -> E.SqlExpr (E.Value Bool) -qIsValid qualUsr nowaday = - E.isNothing (qualUsr E.^. QualificationUserBlockedDue) -- not blocked - E.&&. -- currently valid - (E.val nowaday `E.between` - ( qualUsr E.^. QualificationUserFirstHeld - , qualUsr E.^. QualificationUserValidUntil)) - {- -- | Returns users more than once if they own multiple avs-related valid licences, but no AvsID is known retrieveDriversWithoutAvsId' :: Day -> E.SqlQuery (E.SqlExpr (Entity User)) @@ -189,7 +182,7 @@ retrieveDriversWithoutAvsId' nowaday = do `E.on` (\(_usr :& qualUsr :& qual) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification) E.where_ $ -- is avs licence E.isJust (qual E.^. QualificationAvsLicence) - E.&&. (qualUsr `qIsValid` nowaday) + E.&&. (qualUsr & validQualification nowaday) E.&&. -- AvsId is unknown E.notExists (do avsUsr <- E.from $ E.table @UserAvs @@ -209,7 +202,7 @@ retrieveDriversWithoutAvsId nowaday = do `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)) E.where_ $ -- is avs licence E.isJust (qual E.^. QualificationAvsLicence) - E.&&. (qualUsr `qIsValid` nowaday) -- currently valid + E.&&. (qualUsr & validQualification nowaday) -- currently valid E.&&. -- matches user (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) ) @@ -235,11 +228,8 @@ retrieveDriversRWithoutF nowaday = do `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)) E.where_ $ (qual E.^. QualificationAvsLicence E.==. E.justVal lic) -- matches licence E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId) -- matches user - E.&&. (qualUsr `qIsValid` nowaday) -- currently valid + E.&&. (qualUsr & validQualification nowaday) -- currently valid E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld) E.&&. E.notExists (hasValidQual AvsLicenceVorfeld) return usr -{- -getAdjustLicences :: SchoolId -> QualificationShortand -> Handler Html --} diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index f7f81c5f8..ee3807fc3 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -235,7 +235,7 @@ getCShowR tid ssh csh = do dbtExtraReps = [] tutorialDBTableValidator = def - & defaultSorting [SortAscBy "type", SortAscBy "name"] + & defaultSorting [SortAscBy "type", SortDescBy "name"] (Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable (Any hasExams, examTable) <- runDB . mkExamTable $ Entity cid course diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 9c1b9ff40..6dbef6268 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -8,7 +8,9 @@ module Handler.Course.Users ( queryUser , makeCourseUserTable , postCUsersR, getCUsersR - , colUserSex', colUserQualifications, _userQualifications + , colUserSex' + , colUserQualifications, colUserQualificationBlocked + , _userQualifications ) where import Import @@ -85,7 +87,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 UserTableQualifications = [(Entity Qualification, Entity QualificationUser)] type UserTableData = DBRow ( Entity User , Entity CourseParticipant @@ -124,8 +126,15 @@ _userSubmissionGroup = _dbrOutput . _6 . _Just _userSheets :: Lens' UserTableData (Map SheetName (SheetType SqlBackendKey, Maybe Points)) _userSheets = _dbrOutput . _7 -_userQualifications :: Lens' UserTableData UserTableQualifications -_userQualifications = _dbrOutput . _8 +-- _userQualifications :: Traversal' UserTableData [Entity Qualification] +-- _userQualifications = _dbrOutput . _8 . (traverse _1) +-- last part: ([Entity Qualification] -> f [Entity Qualification]) -> UserTableQualfications -> f UserTableQualifications + +_userQualifications :: Getter UserTableData [Entity Qualification] +_userQualifications = _dbrOutput . _8 . to (fmap fst) + +_userCourseQualifications :: Lens' UserTableData UserTableQualifications +_userCourseQualifications = _dbrOutput . _8 colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) @@ -175,9 +184,15 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns 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 + \(view _userCourseQualifications -> qualis) -> + (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualificationValidCell + +colUserQualificationBlocked :: forall m c. IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) +colUserQualificationBlocked = sortable (Just "qualification-block") (i18nCell MsgTableQualificationBlockedDue) $ + \(view _userCourseQualifications -> qualis) -> + let blocks = qualificationUserBlockedDue . entityVal . snd <$> qualis + --blocks = qaulis <$> view (_2 . _entityVal . _qualificationUserBlockedDue) + in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell blocks $ qualificationBlockedCell data UserTableCsv = UserTableCsv @@ -368,6 +383,8 @@ makeCourseUserTable :: forall h p cols act act'. makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do currentRoute <- fromMaybe (error "makeCourseUserTable called from 404-handler") <$> liftHandler getCurrentRoute Course{..} <- getJust cid + courseQualis <- getCourseQualifications cid + let cqids = entityKey <$> courseQualis tutorials <- selectList [ TutorialCourse ==. cid ] [] exams <- selectList [ ExamCourse ==. cid ] [] sheets <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom] @@ -403,7 +420,10 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do 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 + E.&&. qualification E.^. QualificationId `E.in_` E.valList cqids + + E.orderBy [E.asc $ qualification E.^. QualificationShorthand] -- we should sort by CourseQualificationSortOrder instead, but since we have not seen a course with multiple qualifications yet, we take a shortcut here + return (qualification, qualificationUser) let regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 32cc780c3..d3a4333be 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -70,11 +70,12 @@ postTUsersR tid ssh csh tutn = do dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) - , pure colUserName + , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR , guardOn showSex colUserSex' , pure colUserEmail , pure colUserMatriclenr , pure colUserQualifications + , pure colUserQualificationBlocked ] psValidator = def & defaultSortingByName diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 374f92844..4797a4bdf 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -305,6 +305,13 @@ qualificationDescrCell (view hasQualification -> q@Qualification{..}) = qualific Nothing -> mempty (Just descr) -> spacerCell <> markupCellLargeModal descr +qualificationValidCell :: (IsDBTable m c, HasQualification a, HasQualificationUser a) => a -> DBCell m c +qualificationValidCell q = textCell (qsh <> ": ") <> dayCell vtd + where + qsh = q ^. hasQualification . _qualificationShorthand . _CI + vtd = q ^. hasQualificationUser . _qualificationUserValidUntil + + lmsShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name where diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index cd1a34799..aaa7aa63a 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -151,9 +151,15 @@ instance HasStudyDegree a => HasStudyDegree (Entity a) where instance HasQualification a => HasQualification (Entity a) where hasQualification = _entityVal . hasQualification +instance HasQualification a => HasQualification (a,b) where + hasQualification = _1 . hasQualification + instance HasQualificationUser a => HasQualificationUser (Entity a) where hasQualificationUser = _entityVal . hasQualificationUser +instance HasQualificationUser a => HasQualificationUser (b,a) where + hasQualificationUser = _2 . hasQualificationUser + instance HasLmsUser a => HasLmsUser (Entity a) where hasLmsUser = _entityVal . hasLmsUser