From 11752dc5ac96f36ebf9a4cad43fa4e4b55c1b21c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 20 Sep 2023 14:52:01 +0000 Subject: [PATCH 1/6] fix(lms): treat simultaneous blocks/unblocks correctly --- src/Handler/LMS.hs | 23 +++++++++++++++-------- src/Handler/Utils/Qualification.hs | 9 ++++++--- 2 files changed, 21 insertions(+), 11 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index d85b32ec4..df74c027e 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -318,7 +318,7 @@ queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBloc queryQualBlock = $(sqlLOJproj 2 2) -type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany]) +type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany], E.Value Bool) resultQualUser :: Lens' LmsTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 @@ -338,6 +338,9 @@ resultPrintAck = _dbrOutput . _5 . _unValue . _Just resultCompanyUser :: Lens' LmsTableData [Entity UserCompany] resultCompanyUser = _dbrOutput . _6 +resultValidQualification :: Lens' LmsTableData Bool +resultValidQualification = _dbrOutput . _7 . _unValue + instance HasEntity LmsTableData User where hasEntity = resultUser @@ -396,14 +399,15 @@ isResetRestartAct LmsActRestartData{} = True isResetRestartAct other = isResetAct other -lmsTableQuery :: QualificationId -> LmsTableExpr +lmsTableQuery :: UTCTime -> QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) , E.SqlExpr (Entity User) , E.SqlExpr (Entity LmsUser) , E.SqlExpr (Maybe (Entity QualificationUserBlock)) , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs + , E.SqlExpr (E.Value Bool) ) -lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do +lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do -- RECALL: another outer join on PrintJob did not work out well, since -- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting; -- - using notExists on printJob join condition works, but only delivers single value, while aggregation can deliver all; @@ -420,8 +424,8 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.LeftOute E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser)) let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on! pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this! - E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder - return (qualUser, user, lmsUser, qualBlock, printAcknowledged) + E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder + return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser) mkLmsTable :: ( Functor h, ToSortable h @@ -443,11 +447,11 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "lms" - dbtSQLQuery = lmsTableQuery qid + dbtSQLQuery = lmsTableQuery now qid dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks) -> do + dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock, printAcks, validQ) -> do cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] - return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr) + return (qualUsr, usr, lmsUsr, qUsrBlock, printAcks, cmpUsr, validQ) dbtColonnade = cols cmpMap dbtSorting = mconcat [ single $ sortUserNameLink queryUser @@ -643,6 +647,9 @@ postLmsR sid qsh = do , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row -> qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row + -- DEBUG + , sortable Nothing (i18nCell MsgQualificationValidIndicator) $ \(view resultValidQualification -> b) -> iconBoolCell b -- TODO: just for debugging + -- DEBUG , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification , sortable (Just "ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index a0f4fb706..8efe56139 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -75,9 +75,12 @@ quserToNotify quser cutoff = isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool) 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 + E.where_ $ newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff + E.&&. ((E.just(newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom) + E.||. ( newerBlock E.^. QualificationUserBlockUnblock E.&&. + (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) From e17b26a363f8b29b9b771915a4a4c4bf9dce28da Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 21 Sep 2023 03:09:00 +0000 Subject: [PATCH 2/6] chore(release): 27.4.34 --- CHANGELOG.md | 7 +++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 11 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c258f366f..634bd2783 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.34](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.33...t27.4.34) (2023-09-21) + + +### Bug Fixes + +* **lms:** treat simultaneous blocks/unblocks correctly ([11752dc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/11752dc5ac96f36ebf9a4cad43fa4e4b55c1b21c)) + ## [27.4.33](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.32...t27.4.33) (2023-09-20) diff --git a/nix/docker/version.json b/nix/docker/version.json index 665027c0b..1480b6267 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.33" + "version": "27.4.34" } diff --git a/package-lock.json b/package-lock.json index ede5cb103..002df9556 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.33", + "version": "27.4.34", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 666282fb3..85fa6e713 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.33", + "version": "27.4.34", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index b67586386..03e875bea 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.33 +version: 27.4.34 dependencies: - base - yesod From 273cc288d4d2e1bdec119e012e33e62093a46669 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 21 Sep 2023 08:17:43 +0000 Subject: [PATCH 3/6] chore(lms): more discreet debug info for simultaneous blocks --- src/Handler/LMS.hs | 2 +- src/Handler/Utils/Qualification.hs | 12 ++++++------ src/Handler/Utils/Table/Cells.hs | 18 ++++++++++++++++++ 3 files changed, 25 insertions(+), 7 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index df74c027e..e3862a3e3 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -646,7 +646,7 @@ postLmsR sid qsh = do , 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' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row + qualificationValidReasonCell'' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row (row ^. resultValidQualification) -- TODO: resultValidQualification for debugging only -- DEBUG , sortable Nothing (i18nCell MsgQualificationValidIndicator) $ \(view resultValidQualification -> b) -> iconBoolCell b -- TODO: just for debugging -- DEBUG diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 8efe56139..da50d98b7 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -75,12 +75,12 @@ quserToNotify quser cutoff = isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool) 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.^. QualificationUserBlockUnblock E.&&. - (newerBlock E.^. QualificationUserBlockFrom E.=?. qualBlock E.?. QualificationUserBlockFrom) - ) ) - E.&&. newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser + E.where_ $ newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser + E.&&. newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff + E.&&. ((E.just(newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom) + E.||. ( newerBlock E.^. QualificationUserBlockUnblock -- in case of equal timestamps, any unblock wins + E.&&. (newerBlock E.^. QualificationUserBlockFrom E.=?. qualBlock E.?. QualificationUserBlockFrom) + )) ) -- 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) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 1389b8305..6d41059e9 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -366,6 +366,24 @@ qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser +qualificationValidReasonCell'' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Bool -> Day -> Maybe b -> a -> DBCell m c +qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icErr <> foldMap blc qb + where + quValid = isValidQualification d qu qb + icErr = cell . toWidget . isBad $ quValid /= extValid + ic = cell . toWidget $ iconQualificationBlock quValid + blc (view hasQualificationUserBlock -> QualificationUserBlock{..}) + | showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason + | qualificationUserBlockUnblock = mempty + | otherwise = spacerCell <> dateCell qualificationUserBlockFrom + dc tstamp + | Just toLink <- mbToLink = cell $ do + uuid <- liftHandler $ encrypt uid + modal (formatTimeW SelFormatDate tstamp) (Left $ SomeRoute $ toLink uuid) + -- anchorCellM (toLink <$> encrypt uid) + | otherwise = dateCell tstamp + uid = qu ^. hasQualificationUser . _qualificationUserUser + lmsShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name where From a320ed498ad3fad9089ca35cf9e6f13aa2b55d65 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 21 Sep 2023 09:08:35 +0000 Subject: [PATCH 4/6] chore(lms): fix build erroneous signature --- src/Handler/Utils/Table/Cells.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 6d41059e9..8c77f1dfa 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -366,7 +366,7 @@ qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser -qualificationValidReasonCell'' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Bool -> Day -> Maybe b -> a -> DBCell m c +qualificationValidReasonCell'' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Bool -> Day -> Maybe b -> a -> Bool -> DBCell m c qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icErr <> foldMap blc qb where quValid = isValidQualification d qu qb From db06f5fe42961238ff073c7073699f113c639449 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 21 Sep 2023 09:10:32 +0000 Subject: [PATCH 5/6] chore(lms): deactivate debug column lms view --- src/Handler/LMS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index e3862a3e3..eff51bb81 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -648,7 +648,7 @@ postLmsR sid qsh = do , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row -> qualificationValidReasonCell'' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row (row ^. resultValidQualification) -- TODO: resultValidQualification for debugging only -- DEBUG - , sortable Nothing (i18nCell MsgQualificationValidIndicator) $ \(view resultValidQualification -> b) -> iconBoolCell b -- TODO: just for debugging + -- , sortable Nothing (i18nCell MsgQualificationValidIndicator) $ \(view resultValidQualification -> b) -> iconBoolCell b -- TODO: just for debugging -- DEBUG , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification From 54531a6da98c0fc4c9f7d5d1def8eb03d60ed14f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 21 Sep 2023 09:10:57 +0000 Subject: [PATCH 6/6] chore(release): 27.4.35 --- CHANGELOG.md | 2 ++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 6 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 634bd2783..225e7ee08 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.35](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.34...t27.4.35) (2023-09-21) + ## [27.4.34](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.33...t27.4.34) (2023-09-21) diff --git a/nix/docker/version.json b/nix/docker/version.json index 1480b6267..4efd4d36f 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.34" + "version": "27.4.35" } diff --git a/package-lock.json b/package-lock.json index 002df9556..d2111836e 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.34", + "version": "27.4.35", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 85fa6e713..441aae286 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.34", + "version": "27.4.35", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 03e875bea..7d65cae07 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.34 +version: 27.4.35 dependencies: - base - yesod