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

chore(tutorial): show user qualification info

Browse Source
This commit is contained in:
Steffen Jost 2023-03-27 17:51:34 +00:00
parent d48d922a9c
commit ba8bcc5436
7 changed files with 50 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
models/courses.model
View File

@ -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

20
src/Handler/Admin.hs
View File

@ -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
-}

2
src/Handler/Course/Show.hs
View File

@ -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

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

@ -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

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

@ -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

7
src/Handler/Utils/Table/Cells.hs
View File

@ -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

6
src/Utils/Lens.hs
View File

@ -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