fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

chore(lms): more discreet debug info for simultaneous blocks

Browse Source
This commit is contained in:
Steffen Jost 2023-09-21 08:17:43 +00:00
parent e17b26a363
commit 273cc288d4
3 changed files with 25 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Handler/LMS.hs
View File

@ -646,7 +646,7 @@ postLmsR sid qsh = do
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> 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 "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltip) $ \row -> , 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 -- 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 -- DEBUG

12
src/Handler/Utils/Qualification.hs
View File

@ -75,12 +75,12 @@ quserToNotify quser cutoff =
isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool) 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 isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do
newerBlock <- E.from $ E.table @QualificationUserBlock newerBlock <- E.from $ E.table @QualificationUserBlock
E.where_ $ newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff E.where_ $ newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
E.&&. ((E.just(newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom) E.&&. newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff
E.||. ( newerBlock E.^. QualificationUserBlockUnblock E.&&. E.&&. ((E.just(newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom)
(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)
E.&&. newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser ))
) )
-- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_` -- 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 :: 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)

18
src/Handler/Utils/Table/Cells.hs
View File

@ -366,6 +366,24 @@ qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb
| otherwise = dateCell tstamp | otherwise = dateCell tstamp
uid = qu ^. hasQualificationUser . _qualificationUserUser 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 :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name
where where