From ab48e40ac7e5024b7847b3995e6ae16d1c401c60 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 30 Jun 2023 13:15:39 +0000 Subject: [PATCH] fix(build): major qualfication block quirks fixed --- .../categories/qualification/de-de-formal.msg | 2 +- .../categories/qualification/en-eu.msg | 2 +- src/Database/Esqueleto/Utils.hs | 12 +++++ src/Handler/Admin/Avs.hs | 16 +++---- src/Handler/Course/Users.hs | 8 ++-- src/Handler/LMS.hs | 12 ++--- src/Handler/Profile.hs | 12 ++--- src/Handler/Qualification.hs | 12 +++-- src/Handler/Utils/Qualification.hs | 19 +++++--- src/Handler/Utils/Widgets.hs | 35 +++++++++++++- src/Model/Migration.hs | 2 +- src/Model/Migration/Definitions.hs | 47 ++++++++++--------- templates/lms-user.hamlet | 17 ++++--- test/Database/Fill.hs | 8 ++-- 14 files changed, 129 insertions(+), 75 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 3e85955f0..6de4859e5 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -22,7 +22,7 @@ LmsQualificationValidUntil: Gültig bis TableQualificationLastRefresh: Zuletzt erneuert TableQualificationLastNotified: Letzte Benachrichtigung TableQualificationFirstHeld: Erstmalig -TableQualificationBlockedDue: Entzogen +TableQualificationBlockedDue: Entzug TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst? TableQualificationBlockedTooltipSimple: Falls die Qualifikation aus besonderem Grund vorzeitig widerrufen wurde, so wird das Datum des Widerrufs angezeigt InfoQualificationBlockStatus: Besteht aktuell ein Entzug? Falsch bedeutet, dass ein Entzug zuletzt aufgehoben wurde diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 4f46638db..505235e58 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -22,7 +22,7 @@ LmsQualificationValidUntil: Valid until TableQualificationLastRefresh: Last renewed TableQualificationLastNotified: Last notified TableQualificationFirstHeld: First held -TableQualificationBlockedDue: Revoked +TableQualificationBlockedDue: Revocations TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended? TableQualificationBlockedTooltipSimple: If a date is shown, this qualification has been revoked on that date due to extraordinary reasons TableQualificationNoRenewal: Discontinued diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index a0c5cb6f5..d93d0d5ed 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -13,6 +13,7 @@ module Database.Esqueleto.Utils , strConcat, substring , (=?.), (?=.) , (=~.), (~=.) + , (>~.), (<~.) , or, and , any, all , subSelectAnd, subSelectOr @@ -133,6 +134,17 @@ infixl 4 ~=. (~=.) :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value Bool) (~=.) a b = E.isNothing a E.||. (a E.==. E.just b) +-- | like (>.), but also succeeds if the right-hand side is NULL +infixl 4 >~. +(>~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) +(>~.) a b = E.isNothing b E.||. (E.just a E.>. b) + +-- | like (<.), but also succeeds if the right-hand side is NULL +infixl 4 <~. +(<~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) +(<~.) a b = E.isNothing b E.||. (E.just a E.<. b) + + -- | Negation of `isNothing` which is missing isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) isJust = E.not_ . E.isNothing diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index cda7bf9f0..504733028 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -533,13 +533,13 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do fltrLic qual = E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence) -- TODO: user holding multiple qualifications may appear multiple times in to-delete-in-avs table, which is kinda ugly. Solution: dbtSQLQuery = \(usrAvs `E.InnerJoin` user `E.LeftOuterJoin` qualUser `E.LeftOuterJoin` qual `E.LeftOuterJoin` qblock) -> do - E.on $ qblock E.?. QualificationUserBlockQualificationUser E.==. qualUser E.?. QualificationUserId + E.on $ qblock E.?. QualificationUserBlockQualificationUser E.==. qualUser E.?. QualificationUserId + E.&&. qblock `isLatestBlockBefore` E.val now E.on $ qual E.?. QualificationId E.==. qualUser E.?. QualificationUserQualification E.on $ user E.^. UserId E.=?. qualUser E.?. QualificationUserUser E.on $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser E.where_ $ fltrLic qual - E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids) - E.&&. qblock `isLatestBlockBefore` E.val now + E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids) return (usrAvs, user, qualUser, qual, qblock) dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId) -- ) &&& (queryQualification >>> (E.?. QualificationId)) -- WHY IS THIS AN ERROR? -- Not sure what changes here: @@ -561,12 +561,12 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do icnSuper = text2markup " " <> icon IconSupervisor pure $ toWgt $ mconcat companies , sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q - , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) $ \row -> - cellMaybe (qualificationValidIconCell nowaday (row ^? resultQualBlock)) (row ^? resultQualUser) - , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d - , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d + -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) $ \row -> + -- cellMaybe (qualificationValidIconCell nowaday (row ^? resultQualBlock)) (row ^? resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d - , sortable (Just "blocked") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip) $ \row -> + , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d + , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d + , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row -> cellMaybe (qualificationValidReasonCell True nowaday (row ^? resultQualBlock)) (row ^? resultQualUser) , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \(preview $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> cellMaybe (flip ifIconCell IconNoNotification . not) b diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index ef4ff823b..adf58b292 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -192,7 +192,7 @@ colUserQualifications cutoff = sortable (Just "qualifications") (i18nCell MsgTab (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedValidCell colUserQualificationBlocked :: forall m c. IsDBTable m c => Bool -> Day -> Colonnade Sortable UserTableData (DBCell m c) -colUserQualificationBlocked isAdmin cutoff = sortable (Just "qualification-block") (i18nCell MsgTableQualificationBlockedDue) $ + colUserQualificationBlocked isAdmin cutoff = sortable (Just "qualification-block") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ let qualNamedReasonCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidReasonCell isAdmin cutoff qb qu in \(view _userCourseQualifications -> qualis) -> (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedReasonCell @@ -420,11 +420,11 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do ) ) qualis <- E.select . E.from $ \(qualification `E.InnerJoin` qualificationUser `E.LeftOuterJoin` qualificationBlock) -> do - E.on $ qualificationUser E.^. QualificationUserId E.=?. qualificationBlock E.?. QualificationUserBlockQualificationUser + E.on $ qualificationUser E.^. QualificationUserId E.=?. qualificationBlock E.?. QualificationUserBlockQualificationUser + E.&&. qualificationBlock `isLatestBlockBefore` E.now_ E.on $ qualificationUser E.^. QualificationUserQualification E.==. qualification E.^. QualificationId E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val (entityKey user) - E.&&. qualification E.^. QualificationId `E.in_` E.valList cqids - E.&&. qualificationBlock `isLatestBlockBefore` E.now_ + 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, qualificationBlock) let diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 749fd669a..84753e2a9 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -378,11 +378,11 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOute -- - using notExists on printJob join condition works, but only delivers single value, while aggregation can deliver all; -- experiments with separate sub-query showed that we would need two subqueries to learn whether the request was indeed the latest E.on $ qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser + E.&&. qualBlock `isLatestBlockBefore` E.now_ E.on $ user E.^. UserId E.==. lmsUser E.^. LmsUserUser E.&&. E.val qid E.==. lmsUser E.^. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser - E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification - E.&&. qualBlock `isLatestBlockBefore` E.now_ + E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken! let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) @@ -598,10 +598,10 @@ postLmsR sid qsh = do (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs in wgtCell companies , colUserMatriclenr - -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) - , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d - , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d + -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d + , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d + , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row -> qualificationValidReasonCell isAdmin nowaday (row ^? resultQualBlock) row , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip @@ -764,7 +764,7 @@ viewLmsUserR msid mqsh uuid = do pure (qBlock, qbUsr Ex.?. UserDisplayName) return $ Map.singleton quid blocks ) qs - return (usr,qs,bs) + return (usr, qs, Map.filter notNull bs) let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|] siteLayout heading $ do setTitle $ toHtml userDisplayName diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 43e3c390b..71d55abca 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -958,20 +958,20 @@ mkQualificationsTable = { dbtIdent = "userQualifications" :: Text , dbtSQLQuery = \(quali `E.InnerJoin` quser `E.LeftOuterJoin` qblock) -> do E.on $ quser E.^. QualificationUserId E.=?. qblock E.?. QualificationUserBlockQualificationUser + E.&&. qblock `isLatestBlockBefore` E.val now E.on $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId - E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid - E.&&. qblock `isLatestBlockBefore` E.val now + E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid return (quali, quser, qblock) , dbtRowKey = \(_quali `E.InnerJoin` quser `E.LeftOuterJoin` _qblock) -> quser E.^. QualificationUserId , dbtProj = dbtProjId , dbtColonnade = mconcat [ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool) , sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal) - , sortable (Just "blocked") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> - qualificationValidReasonCell False (utctDay now) (row ^? _dbrOutput . _3 . _Just . _entityVal) (row ^. _dbrOutput . _2 . _entityVal) - , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil ) - , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld ) + , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh) + , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil ) + , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> + qualificationValidReasonCell False (utctDay now) (row ^? _dbrOutput . _3 . _Just . _entityVal) (row ^. _dbrOutput . _2 . _entityVal) ] , dbtSorting = mconcat [ sortSchool $ to (\(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationSchool) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index ef2cda91c..16fdc38ca 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -333,13 +333,13 @@ qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps -- - E.on $ qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser + E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId + E.&&. qualBlock `isLatestBlockBefore` E.now_ E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.where_ $ fltr qualUser - E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) - E.&&. qualBlock `isLatestBlockBefore` E.now_ + E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) return (qualUser, user, lmsUser, qualBlock) @@ -382,9 +382,10 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do [ single $ sortUserNameLink queryUser , single $ sortUserEmail queryUser , single $ sortUserMatriclenr queryUser - , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) + , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) + , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}" , queryLmsUser row E.?. LmsUserStarted]) @@ -555,7 +556,7 @@ postQualificationR sid qsh = do [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- Admin-only actions [ singletonMap QualificationActUnblock $ QualificationActUnblockData - <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationBlockReason) Nothing + <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) , singletonMap QualificationActBlock $ QualificationActBlockData <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing @@ -585,6 +586,7 @@ postQualificationR sid qsh = do -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil)) , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d + , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> qualificationValidReasonCell isAdmin nowaday (row ^? resultQualBlock) row , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 821679e27..83b7dfab0 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -16,6 +16,11 @@ import qualified Database.Esqueleto.Experimental as E -- might need TypeApplic import qualified Database.Esqueleto.Utils as E import Handler.Utils.DateTime (toMidnight) +import Handler.Utils.Widgets (statusHtml) + +statusQualificationBlock :: Bool -> Html +statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificationBlock s + -- needs refactoring, probbably no longer helpful mkQualificationBlocked :: QualificationBlockStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock @@ -65,14 +70,14 @@ quserToNotify quser cutoff = ) ) --- condition to ensure that the lastes QualificationUserBlock was picked +-- condition to ensure that the lastes QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool) -isLatestBlockBefore qualBlock cutoff = E.notExists $ do - newerBlock <- E.from $ E.table @QualificationUserBlock - E.where_ $ newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff - E.&&. E.just (newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom - E.&&. newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser - +isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do + newerBlock <- E.from $ E.table @QualificationUserBlock + E.where_ $ newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff + E.&&. E.just (newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom + E.&&. newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser + ) -- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_` quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 0d50aaa20..23a4b3a37 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -122,6 +122,12 @@ editedByW fmt tm usr = do ft <- handlerToWidget $ formatTime fmt tm [whamlet|_{MsgUtilEditedBy usr ft}|] + +---------- +-- HEAT -- +---------- + + boolHeat :: Bool -- ^ @isHot@ -> Milli boolHeat = bool 0 1 @@ -148,7 +154,6 @@ invCoHeat :: ( Real a, Real b) invCoHeat (realToFrac -> full) (realToFrac -> achieved) = fromRational $ cutOffPercent 0.3 (full^2) (achieved^2) - dualHeat :: ( Real a, Real b, Real c ) => a -> b -> c -> Milli -- ^ Distinguishes zero, zero is mapped to 0, @optimal@ is mapped to 1, @full@ is mapped to 2 @@ -180,6 +185,34 @@ invDualCoHeat :: ( Real a, Real b, Real c ) invDualCoHeat optimal full achieved = 2 - dualCoHeat optimal full achieved +----------- +-- COLOR -- +----------- + +-- TODO: someone with frontend capabilities should get rid of class tooltip__handle and check theme consistent colors + +statusHtml :: MessageStatus -> Html -> Html +statusHtml sts wgt = + [shamlet| + + ^{wgt} + |] + +statusWidget :: MessageStatus -> Widget -> Widget +statusWidget sts wgt = + [whamlet| + + ^{wgt} + |] + +heatedWidget :: Milli -> Widget -> Widget +heatedWidget ht wgt = + [whamlet| + + ^{wgt} + |] + + examOccurrenceMappingDescriptionWidget :: ExamOccurrenceRule -> Set ExamOccurrenceMappingDescription -> Widget examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets/exam-occurrence-mapping-description") where diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 9e18fb87b..dc0f83210 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Sarah Vaupel +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 8f5a086da..022065a33 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -855,29 +855,32 @@ customMigrations = mapF $ \case ALTER TABLE "term" DROP COLUMN "active"; |] - Migration20230524QualificationUserBlock -> - unlessM (tableExists "qualification_user_block") $ do - [executeQQ| - CREATE TABLE "qualification_user_block" - ( "id" SERIAL8 PRIMARY KEY UNIQUE - , "qualification_user" bigint NOT NULL - , "from" timestamp with time zone NOT NULL - , "reason" character varying NOT NULL - , "blocker" bigint - , CONSTRAINT qualification_user_block_qualification_user_fkey FOREIGN KEY (qualification_user) REFERENCES qualification_user(id) ON DELETE CASCADE - , CONSTRAINT qualification_user_block_blocker_fkey FOREIGN KEY (blocker) REFERENCES user(id) - ) - |] + Migration20230524QualificationUserBlock -> + whenM (andM [ not <$> tableExists "qualification_user_block" + , tableExists "qualification_user" + , columnExists "qualification_user" "blocked_due" + ] ) $ do + [executeQQ| + CREATE TABLE "qualification_user_block" + ( "id" SERIAL8 PRIMARY KEY UNIQUE + , "qualification_user" bigint NOT NULL + , "from" timestamp with time zone NOT NULL + , "reason" character varying NOT NULL + , "blocker" bigint + , CONSTRAINT qualification_user_block_qualification_user_fkey FOREIGN KEY ("qualification_user") REFERENCES "qualification_user"(id) ON DELETE CASCADE + , CONSTRAINT qualification_user_block_blocker_fkey FOREIGN KEY ("blocker") REFERENCES "user"(id) + ) + |] - let getBlocks = [queryQQ|SELECT "id", "blocked_due" FROM "qualification_user" WHERE "blocked_due" IS NOT NULL|] - migrateBlocks [ fromPersistValue -> Right (quid :: QualificationUserId), fromPersistValue -> Right (Just (Legacy.QualificationBlocked{..} :: Legacy.QualificationBlocked)) ] = - [executeQQ|INSERT INTO "qualification_user_block" ("qualification_user", "from", "reason") VALUES (#{quid}, #{qualificationBlockedDay}, #{qualificationBlockedReason})|] - migrateBlocks _ = return () - in runConduit $ getBlocks .| C.mapM_ migrateBlocks + let getBlocks = [queryQQ|SELECT "id", "blocked_due" FROM "qualification_user" WHERE "blocked_due" IS NOT NULL|] + migrateBlocks [ fromPersistValue -> Right (quid :: QualificationUserId), fromPersistValue -> Right (Just (Legacy.QualificationBlocked{..} :: Legacy.QualificationBlocked)) ] = + [executeQQ|INSERT INTO "qualification_user_block" ("qualification_user", "from", "reason") VALUES (#{quid}, #{qualificationBlockedDay}, #{qualificationBlockedReason})|] + migrateBlocks _ = return () + in runConduit $ getBlocks .| C.mapM_ migrateBlocks - [executeQQ| - ALTER TABLE "qualification_user" DROP COLUMN "blocked_due"; - |] + [executeQQ| + ALTER TABLE "qualification_user" DROP COLUMN "blocked_due"; + |] tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool diff --git a/templates/lms-user.hamlet b/templates/lms-user.hamlet index a78c9523c..a084f582a 100644 --- a/templates/lms-user.hamlet +++ b/templates/lms-user.hamlet @@ -11,9 +11,9 @@ $else

- #{qualificationShorthand quali} - #{qualificationName quali} (#{qualificationSchool quali})   - - #{iconQualificationBlock (E.unValue validity)} + #{qualificationShorthand quali} # + #{statusQualificationBlock (E.unValue validity)} # + #{qualificationName quali} (#{qualificationSchool quali})
$maybe (Entity quid qualUsr) <- mbQualUsr @@ -28,12 +28,11 @@ $else $forall (Entity _ block, blockerDN) <- qblock
  • #{iconQualificationBlock (view _qualificationUserBlockUnblock block)} - \ #{view _qualificationUserBlockReason block} -

    - $maybe bdn <- E.unValue blockerDN - ^{editedByW SelFormatDateTime (view _qualificationUserBlockFrom block) bdn} - $nothing - ^{formatTimeW SelFormatDateTime (view _qualificationUserBlockFrom block)} + \ #{view _qualificationUserBlockReason block} # + $maybe bdn <- E.unValue blockerDN + ^{editedByW SelFormatDateTime (view _qualificationUserBlockFrom block) bdn} + $nothing + ^{formatTimeW SelFormatDateTime (view _qualificationUserBlockFrom block)}

    _{MsgTableQualificationLastRefresh}
    ^{formatTimeW SelFormatDate (qualificationUserLastRefresh qualUsr)}
    _{MsgTableQualificationFirstHeld} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 99bbef4d8..91af04d30 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -691,7 +691,7 @@ fillDb = do qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True (Just AvsLicenceVorfeld) $ Just "F4466" qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 12) (Just 6) (Just $ CalendarDiffDays 2 3) False (Just AvsLicenceRollfeld) $ Just "R2801" qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True Nothing Nothing - qfjost <- insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) True (n_day' $ -9) -- TODO: better dates! + qfjost <- insert' $ QualificationUser jost qid_f (n_day 11) (n_day $ -1) (n_day $ -22) True (n_day' $ -9) -- TODO: better dates! void . insert $ QualificationUserBlock qfjost False (n_day' $ -6) "First block" (Just svaupel) void . insert $ QualificationUserBlock qfjost True (n_day' $ -5) "Second unblock" (Just gkleen) void . insert $ QualificationUserBlock qfjost False (n_day' $ -4) "Third block" Nothing @@ -699,7 +699,7 @@ fillDb = do void . insert $ QualificationUserBlock qfjost False (n_day' $ -1) "Fifth block" (Just svaupel) void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) True (n_day' $ -9) -- TODO: better dates! void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) True (n_day' $ -9) -- TODO: better dates! - qfkleen <- insert' $ QualificationUser gkleen qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) True (n_day' $ -9) + qfkleen <- insert' $ QualificationUser gkleen qid_f (n_day 33) (n_day $ -4) (n_day $ -20) True (n_day' $ -9) void . insert $ QualificationUserBlock qfkleen False (n_day' 1) "Future block" (Just svaupel) void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) False (n_day' $ -1) void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) True (n_day' $ -9) @@ -707,8 +707,8 @@ fillDb = do qftest <- insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) False (n_day' $ -9) void . insert $ QualificationUserBlock qftest False (n_day' $ -7) "Some longer explanation for the block, which explains what has happened here, but is probably to long to be shown inline!" (Just jost) void . insert' $ QualificationUser tinaTester qid_r (n_day 3) (n_day $ -60) (n_day $ -250) False (n_day' $ -3) - qrkleen <- insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) True (n_day' $ -4) - void . insert $ QualificationUserBlock qrkleen True (n_day' $ -7) "Not a block, just a reason for granting" (Just jost) + qrkleen <- insert' $ QualificationUser gkleen qid_r (n_day 44) (n_day $ -2) (n_day $ -9) True (n_day' $ -4) + void . insert $ QualificationUserBlock qrkleen True (n_day' $ -7) "Granted by lottery win" (Just jost) void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) False (n_day' $ -6) -- void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) True (n_day' $ -9) void . insert' $ QualificationUser svaupel qid_l (n_day 1) (n_day $ -1) (n_day $ -2) True (n_day' $ -7)