chore(tutorial): show user qualification info

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

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

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

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 :: Traversal' UserTableData [Entity Qualification]
-_userQualifications = _dbrOutput . _8
+-- _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') ->
+  \(view _userCourseQualifications -> qualis) ->
-    let qualis = sortOn (qualificationName . entityVal) qualis'
+      (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualificationValidCell
-     in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualificationCell . entityVal
+
+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

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

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

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