From ed44edc199559e4d03365800b0828cc715254c41 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 9 Oct 2024 18:11:22 +0200 Subject: [PATCH] chore(daily): show course associated qualifications --- models/lms.model | 2 +- src/Handler/School/DayTasks.hs | 26 ++++++++++++++++++++++---- src/Handler/Utils/Qualification.hs | 12 ++++++++++++ src/Handler/Utils/Table/Cells.hs | 6 +++--- src/Handler/Utils/Table/Pagination.hs | 17 +++++++++++++++++ src/Model/Types/Avs.hs | 2 +- templates/table/cell/listInline.hamlet | 10 ++++++++++ test/Database/Fill.hs | 2 ++ 8 files changed, 68 insertions(+), 9 deletions(-) create mode 100644 templates/table/cell/listInline.hamlet diff --git a/models/lms.model b/models/lms.model index 9a7712c29..50b686fcf 100644 --- a/models/lms.model +++ b/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? diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 5e6d8ba4e..e37793048 100644 --- a/src/Handler/School/DayTasks.hs +++ b/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 diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index cec61ac9e..9bd59310d 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/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 diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index c5bddd475..0d43a13fe 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/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" diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 10fb0d544..d1c449fde 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/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 diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 26c0aad49..f0a9540bd 100644 --- a/src/Model/Types/Avs.hs +++ b/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... diff --git a/templates/table/cell/listInline.hamlet b/templates/table/cell/listInline.hamlet new file mode 100644 index 000000000..2c4b83e33 --- /dev/null +++ b/templates/table/cell/listInline.hamlet @@ -0,0 +1,10 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +