chore(daily): show course associated qualifications

models/lms.model

@@ -24,7 +24,7 @@ Qualification
     -- across all schools, only one qualification may be a driving licence -- NO LONGER TRUE
     -- UniqueQualificationAvsLicence avsLicence      !force -- either empty or unique 
     -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints!
-  deriving Show Eq Generic
+  deriving Show Eq Generic Binary
 
 -- TODOs:
 --  - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen?

src/Handler/School/DayTasks.hs

@@ -24,8 +24,9 @@ import qualified Data.Aeson  as Aeson
 
 -- import Database.Persist.Sql (updateWhereCount)
 import           Database.Esqueleto.Experimental ((:&)(..))
-import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
 import qualified Database.Esqueleto.Experimental as E
+import qualified Database.Esqueleto.PostgreSQL as E
+import qualified Database.Esqueleto.Legacy as EL (on, from) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 import Database.Esqueleto.PostgreSQL.JSON as E
@@ -100,8 +101,15 @@ type DailyTableExpr =
     `E.InnerJoin` E.SqlExpr (Entity TutorialParticipant)
     `E.InnerJoin` E.SqlExpr (Entity User)
   )
-type DailyTableOutput = E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial), E.SqlExpr (Entity TutorialParticipant), E.SqlExpr (Entity User), E.SqlExpr (E.Value (Maybe CompanyId)))
-type DailyTableData   = DBRow (Entity Course, Entity Tutorial, Entity TutorialParticipant, Entity User, E.Value (Maybe CompanyId))
+type DailyTableOutput = E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial), E.SqlExpr (Entity TutorialParticipant), E.SqlExpr (Entity User), E.SqlExpr (E.Value (Maybe CompanyId)), E.SqlExpr (E.Value (Maybe [QualificationId])))
+type DailyTableData   = DBRow
+  ( Entity Course
+  , Entity Tutorial
+  , Entity TutorialParticipant
+  , Entity User
+  , E.Value (Maybe CompanyId)
+  , E.Value (Maybe [QualificationId])
+  )
 
 queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course)
 queryCourse = $(sqlIJproj 4 1)
@@ -133,6 +141,10 @@ resultUser = _dbrOutput . _4
 resultCompanyId :: Traversal' DailyTableData CompanyId
 resultCompanyId = _dbrOutput . _5 . _unValue . _Just
 
+resultCourseQualis :: Traversal' DailyTableData [QualificationId]
+resultCourseQualis = _dbrOutput . _6 . _unValue . _Just
+
+
 instance HasEntity DailyTableData User where
   hasEntity = resultUser
 
@@ -149,7 +161,12 @@ mkDailyTable isAdmin ssh nd = do
       EL.on $ tut E.^. TutorialId     E.==. tpu E.^. TutorialParticipantTutorial
       EL.on $ usr E.^. UserId         E.==. tpu E.^. TutorialParticipantUser
       E.where_ $ tut E.^. TutorialId `E.in_` E.valList tuts
-      return (crs, tut, tpu, usr, selectCompanyUserPrime usr)
+      let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do
+            E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId
+            let cqQual  = cq E.^. CourseQualificationQualification
+                cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual]
+            return $ E.arrayAggWith E.AggModeAll cqQual cqOrder
+      return (crs, tut, tpu, usr, selectCompanyUserPrime usr, associatedQualifications)
     dbtRowKey = queryTutorial >>> (E.^. TutorialId)
     dbtProj   = dbtProjId
     dbtColonnade = mconcat
@@ -160,6 +177,7 @@ mkDailyTable isAdmin ssh nd = do
                       = row ^. resultCourse . _entityVal
               tutName = row ^. resultTutorial . _entityVal . _tutorialName
           in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName
+      , sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell
       , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid
       , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid
       , colUserNameModalHdr MsgCourseParticipant ForProfileDataR

src/Handler/Utils/Qualification.hs

@@ -18,6 +18,18 @@ import qualified Database.Esqueleto.Experimental as E   -- might need TypeApplic
 import qualified Database.Esqueleto.Utils as E
 
 import Handler.Utils.Widgets  (statusHtml)
+import Handler.Utils.Memcached
+
+
+-- A type for saving QualificationId -> Qualfication queries
+newtype MemcachedQualification = MemcachedQualification { unMemachedQualification :: QualificationId }
+  deriving newtype (Eq, Ord, Show, Binary)
+instance NFData MemcachedQualification where
+  rnf MemcachedQualification{..} = rnf unMemachedQualification
+
+retrieveQualification :: (MonadHandler m, HandlerSite m ~ UniWorX) => QualificationId -> m (Maybe Qualification)
+retrieveQualification qid = liftHandler $ memcachedBy (Just . Right $ 7 * diffHour) (MemcachedQualification qid) $ runDBRead $ get qid
+
 
 -- | Compute new valid date from old one and from validDuration in months
 --   Mainly to document which add months functions to use

src/Handler/Utils/Table/Cells.hs

@@ -14,7 +14,7 @@ import Handler.Utils.DateTime
 import Handler.Utils.Widgets
 import Handler.Utils.Occurrences
 import Handler.Utils.LMS (lmsUserStatusWidget)
-import Handler.Utils.Qualification (isValidQualification)
+import Handler.Utils.Qualification (isValidQualification, retrieveQualification)
 
 type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
 
@@ -384,7 +384,7 @@ companyIdCell cid = companyCell csh csh False
 qualificationIdCell :: (IsDBTable m c) => QualificationId -> DBCell m c
 qualificationIdCell qid = anchorCellM' qual link name
   where
-    qual = liftHandler $ runDBRead $ get qid
+    qual = retrieveQualification qid
     link (Just Qualification{..}) = QualificationR qualificationSchool qualificationShorthand
     link Nothing = HelpR
     name Nothing = text2widget "Error: unknown QID"
@@ -393,7 +393,7 @@ qualificationIdCell qid = anchorCellM' qual link name
 qualificationIdShortCell :: (IsDBTable m c) => QualificationId -> DBCell m c
 qualificationIdShortCell qid = anchorCellM' qual link name
   where
-    qual = liftHandler $ runDBRead $ get qid
+    qual = retrieveQualification qid
     link (Just Qualification{..}) = QualificationR qualificationSchool qualificationShorthand
     link Nothing = HelpR
     name Nothing = text2widget "Error: unknown QID"

src/Handler/Utils/Table/Pagination.hs

@@ -61,6 +61,7 @@ module Handler.Utils.Table.Pagination
   , cellTooltip, cellTooltips, cellTooltipIcon, cellTooltipWgt
   , listCell, listCell', listCellOf, listCellOf'
   , ilistCell, ilistCell', ilistCellOf, ilistCellOf'
+  , listInlineCell, listInlineCell', ilistInlineCell, ilistInlineCell'
   , formCell, DBFormResult(..), getDBFormResult
   , dbSelect, dbSelectIf
   , (&)
@@ -1853,6 +1854,22 @@ maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $
       toWidget $ x2widgetUnauth Nothing
 
 
+listInlineCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCell m a) -> DBCell m a
+listInlineCell = listInlineCell' . return
+
+listInlineCell' :: (IsDBTable m a, MonoFoldable mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a
+listInlineCell' mkXS mkCell = ilistInlineCell' (otoList <$> mkXS) $ const mkCell
+
+ilistInlineCell :: (IsDBTable m a, MonoFoldableWithKey mono) => mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a
+ilistInlineCell = ilistInlineCell' . return
+
+ilistInlineCell' :: (IsDBTable m a, MonoFoldableWithKey mono) => WriterT a m mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a
+ilistInlineCell' mkXS mkCell = review dbCell . ([], ) $ do
+  xs <- mkXS
+  cells <- forM (otoKeyedList xs) $
+    \(view dbCell . uncurry mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
+  return $(widgetFile "table/cell/listInline")
+
 listCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCell m a) -> DBCell m a
 listCell = listCell' . return
 

src/Model/Types/Avs.hs

@@ -280,7 +280,7 @@ discernAvsIds someid = aux someid
 
 
 data AvsLicence = AvsNoLicence | AvsLicenceVorfeld | AvsLicenceRollfeld
-  deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Finite, Universe, NFData)
+  deriving (Bounded, Enum, Eq, Ord, Read, Show, Generic, Finite, Universe, NFData, Binary)
 
 instance ToJSON AvsLicence where
     -- toJSON al = Number $ fromEnum AvsLicence -- would do, but...

templates/table/cell/listInline.hamlet

@@ -0,0 +1,10 @@
+$newline never
+
+$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
+$#
+$# SPDX-License-Identifier: AGPL-3.0-or-later
+
+<ul .list--iconless .list--inline .list--comma-separated>
+  $forall (attrs, widget) <- cells
+    <li *{attrs}>
+      ^{widget}

test/Database/Fill.hs

@@ -1037,6 +1037,8 @@ fillDb = do
           }
         insert_ $ CourseEdit jost now c
         when (tyear >= currentYear)             $ insert_ $ CourseQualification c qid_f 2
+        when (tyear == currentYear)             $ insert_ $ CourseQualification c qid_r 4
+        when (tyear == currentYear)             $ insert_ $ CourseQualification c qid_rp 44
         when (tyear >= succ currentYear)        $ insert_ $ CourseQualification c qid_r 3
         when (tyear >= succ (succ currentYear)) $ insert_ $ CourseQualification c qid_l 1
         insert_ Sheet