From 878f98604cc48eee92f509fddd63e2b887d7a50e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 26 Jun 2023 16:28:17 +0000 Subject: [PATCH] refactor(qualifications): suggestions for qualification view block acts (WIP) --- .../categories/qualification/de-de-formal.msg | 2 +- .../categories/qualification/en-eu.msg | 2 +- src/Handler/Qualification.hs | 110 ++++++++++-------- src/Handler/Tutorial/Form.hs | 2 +- src/Handler/Utils/Avs.hs | 5 +- src/Handler/Utils/Qualification.hs | 10 +- src/Handler/Utils/Table/Cells.hs | 47 +++++--- src/Jobs/Handler/LMS.hs | 8 +- .../Handler/SendNotification/Qualification.hs | 11 +- src/Utils.hs | 8 +- src/Utils/Lens.hs | 7 +- 11 files changed, 120 insertions(+), 92 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 77f754e62..b77bd3416 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -24,7 +24,7 @@ TableQualificationLastNotified: Letzte Benachrichtigung TableQualificationFirstHeld: Erstmalig TableQualificationBlockedDue: Entzogen TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst? -TableQualificationBlockedTooltipSimple: Wann wurde die Qualifikation aus besonderem Grund wiederrufen? +TableQualificationBlockedTooltipSimple: Falls die Qualifikation aus besonderem Grund vorzeitig widerrufen wurde, so wird das Datum des Widerrufs angezeigt TableQualificationNoRenewal: Auslaufend TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch weiterhin gültig sein. QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls diese Qualikation bald ablaufen sollte? diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 57dcf853b..ada108cca 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -24,7 +24,7 @@ TableQualificationLastNotified: Last notified TableQualificationFirstHeld: First held TableQualificationBlockedDue: Revoked TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended? -TableQualificationBlockedTooltipSimple: When was this qualification revoked due to extraordinary reasons? +TableQualificationBlockedTooltipSimple: If a date is shown, this qualification has been revoked on that date due to extraordinary reasons TableQualificationNoRenewal: Discontinued TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid. QualificationScheduleRenewalTooltip: Will there be a notification, if this qualification is about to expire soon? diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 9f76a6c1e..c8a693e13 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -80,7 +80,7 @@ mkQualificationAllTable isAdmin = do Ex.where_ $ filterSvs quser cactive = Ex.subSelectCount $ do quser <- Ex.from $ Ex.table @QualificationUser - Ex.where_ $ filterSvs quser Ex.&&. validQualification (utctDay now) quser + Ex.where_ $ filterSvs quser Ex.&&. validQualification now quser return (quali, cactive, cusers) dbtRowKey = (Ex.^. QualificationId) dbtProj = dbtProjId @@ -152,7 +152,7 @@ data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. , qtcCompanyNumbers :: CsvSemicolonList Int , qtcValidUntil :: Day , qtcLastRefresh :: Day - , qtcBlocked :: Maybe Day + , qtcBlocked :: Maybe UTCTime , qtcScheduleRenewal:: Bool , qtcLmsStatusTxt :: Maybe Text , qtcLmsStatusDay :: Maybe Day @@ -225,7 +225,7 @@ queryLmsUser = $(sqlLOJproj 3 2) queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) queryQualBlock = $(sqlLOJproj 3 3) -type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), [Entity UserCompany], Maybe (Entity LmsUser)) +type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany]) resultQualUser :: Lens' QualificationTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 @@ -236,11 +236,11 @@ resultUser = _dbrOutput . _2 resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser) resultLmsUser = _dbrOutput . _3 . _Just -resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany] -resultCompanyUser = _dbrOutput . _4 - resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock) -resultQualBlock = _dbrOutput . _5 . _Just +resultQualBlock = _dbrOutput . _4 . _Just + +resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany] +resultCompanyUser = _dbrOutput . _5 instance HasEntity QualificationTableData User where @@ -277,12 +277,10 @@ data QualificationTableActionData | QualificationActUnexpireData | QualificationActBlockSupervisorData | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } - -- idea: implement some standard answers in addition to a free form answer - | QualificationActBlockData { qualTableActBlockStandard :: QualificationBlockStandardReason, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } - | QualificationActUnblockData + | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool} | QualificationActRenewData | QualificationActGrantData { qualTableActGrantUntil :: Day } - deriving (Eq, Ord, Read, Show, Generic) + deriving (Eq, Ord, Show, Generic) isExpiryAct :: QualificationTableActionData -> Bool isExpiryAct QualificationActExpireData = True @@ -292,7 +290,7 @@ isExpiryAct _ = False isBlockAct :: QualificationTableActionData -> Bool isBlockAct QualificationActBlockSupervisorData = True isBlockAct QualificationActBlockData{} = True -isBlockAct QualificationActUnblockData = True +isBlockAct QualificationActUnblockData{} = True isBlockAct _ = False blockActRemoveSupervisors :: QualificationTableActionData -> Bool @@ -328,10 +326,10 @@ qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) E.&&. E.notExists (E.from $ \earlierBlock -> - E.where_ $ earlierBlock E.^. QualificationUserBlockId E.!=. qualBlock E.^. QualificationUserBlockId - E.&&. earlierBlock E.^. QualificationUserBlockFrom E.>. qualBlock E.^. QualificationUserBlockFrom + E.where_ $ earlierBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser + E.&&. E.just (earlierBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom ) - return (qualUser, user, lmsUser) + return (qualUser, user, lmsUser, qualBlock) mkQualificationTable :: @@ -360,14 +358,14 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs dbtSQLQuery = qualificationTableQuery qid fltrSvs dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr) -> do + dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do -- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId -- E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr) -- E.orderBy [E.asc (comp E.^. CompanyName)] -- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor) cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] - return (qualUsr, usr, lmsUsr, cmpUsr) + return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr) dbtColonnade = cols cmpMap dbtSorting = mconcat [ single $ sortUserNameLink queryUser @@ -376,7 +374,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) - , single ("blocked-due" , SortColumnNeverNull $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) + , 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]) , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) @@ -386,7 +384,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName) ) - , single ("validity", SortColumn $ queryQualUser >>> validQualification nowaday) + -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser @@ -415,7 +413,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit ) - , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) + , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> if | Just renewal <- mbRenewal , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal @@ -452,7 +450,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do <*> (view resultCompanyUser >>= getCompanyNos) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) - <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) + <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom) <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) <*> getStatusPlusTxt <*> getStatusPlusDay @@ -510,32 +508,53 @@ postQualificationR sid qsh = do now <- liftIO getCurrentTime let nowaday = utctDay now ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do - qent@Entity{entityVal=Qualification{ - qualificationAuditDuration=auditMonths - , qualificationValidDuration=validMonths + qent@Entity{ + entityKey=qid + , entityVal=Qualification{ + qualificationAuditDuration=auditMonths + , qualificationValidDuration=validMonths }} <- getBy404 $ SchoolQualificationShort sid qsh - let dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths + let getBlockReasons unblk = Ex.select $ do + (quser :& qblock) <- Ex.from $ Ex.table @QualificationUser + `Ex.innerJoin` Ex.table @QualificationUserBlock + `Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser) + Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qid + Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock) + Ex.groupBy (qblock Ex.^. QualificationUserBlockReason) + let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows + Ex.orderBy [Ex.desc countRows'] + Ex.limit 7 + pure (qblock Ex.^. QualificationUserBlockReason) + mkOption :: Ex.Value Text -> Option Text + mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } + suggestionsBlock :: HandlerFor UniWorX (OptionList Text) + suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons Ex.not_) + suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id) + dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) acts = mconcat $ [ singletonMap QualificationActExpire $ pure QualificationActExpireData , singletonMap QualificationActUnexpire $ QualificationActUnexpireData <$ aformMessage msgUnexpire ] ++ bool - [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin actions, ie. Supervisor - [ singletonMap QualificationActUnblock $ pure QualificationActUnblockData -- Admin-only actions + -- nonAdmin actions, ie. Supervisor + [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] + -- Admin-only actions + [ singletonMap QualificationActUnblock $ QualificationActUnblockData + <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationBlockReason) Nothing + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) , singletonMap QualificationActBlock $ QualificationActBlockData - <$> apreq textField (fslI MsgQualificationBlockReason) Nothing - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False) + <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False) , singletonMap QualificationActRenew $ pure QualificationActRenewData , singletonMap QualificationActGrant $ QualificationActGrantData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry <* aformMessage msgGrantWarning ] isAdmin linkLmsUser = toMaybe isAdmin LmsUserR - linkUserName = bool ForProfileR ForProfileDataR isAdmin - blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin + linkUserName = bool ForProfileR ForProfileDataR isAdmin colChoices cmpMap = mconcat [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , colUserNameModalHdr MsgLmsUser linkUserName @@ -550,11 +569,11 @@ postQualificationR sid qsh = do (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs in wgtCell companies , guardMonoid isAdmin colUserMatriclenr - , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) + -- , 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 "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple - ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> blockedDueCell b + , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> + qualificationValidReasonCell isAdmin nowaday (row ^. resultQualUser) (row ^? resultQualBlock) , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) @@ -571,7 +590,7 @@ postQualificationR sid qsh = do addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks reloadKeepGetParams $ QualificationR sid qsh (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do - runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing + runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing Nothing addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers reloadKeepGetParams $ QualificationR sid qsh (action, selectedUsers) | isExpiryAct action -> do @@ -585,29 +604,24 @@ postQualificationR sid qsh = do reloadKeepGetParams $ QualificationR sid qsh (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do let selUserIds = Set.toList selectedUsers - qubr = case action of - QualificationActUnblockData -> Nothing - QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday - QualificationActBlockData{..} -> Just $ QualificationBlocked - { qualificationBlockedDay = nowaday - , qualificationBlockedReason = qualTableActBlockReason - } - _ -> error "Handle.Qualification.isBlockAct returned non-block action" + (unblock, reason) = case action of + QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany) + QualificationActBlockData{..} -> (False, Left qualTableActBlockReason) + QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason) + _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks notify = case action of QualificationActBlockData{qualTableActNotify} -> qualTableActNotify _ -> False oks <- runDB $ do when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds] - qualificationUserBlocking qid selUserIds notify qubr + qualificationUserBlocking qid selUserIds unblock reason notify let nrq = length selectedUsers warnLevel = if | oks < 0 -> Error | oks == nrq -> Success | otherwise -> Warning - fbmsg = if - | isNothing qubr -> MsgQualificationStatusUnblock - | otherwise -> MsgQualificationStatusBlock + fbmsg = if unblock then MsgQualificationStatusUnblock else MsgQualificationStatusBlock addMessageI warnLevel $ fbmsg qsh oks nrq reloadKeepGetParams $ QualificationR sid qsh _ -> addMessageI Error MsgInvalidFormAction diff --git a/src/Handler/Tutorial/Form.hs b/src/Handler/Tutorial/Form.hs index 22ac01d81..6e4e608dd 100644 --- a/src/Handler/Tutorial/Form.hs +++ b/src/Handler/Tutorial/Form.hs @@ -90,7 +90,7 @@ tutorialForm cid template html = do <*> tutorForm where tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text)) - tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $ + tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (toPathPiece $ CI.original t)) . Set.toAscList) . runDB $ fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid return $ tutorial E.^. TutorialType diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 550f4edd6..03d059561 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -259,8 +259,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences -- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either - let nowaday = utctDay now - vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences + let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences rollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld' vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld' rollfeld = Set.map avsLicencePersonID rollfeld' @@ -275,7 +274,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do (quali E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification) -- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work! E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic) -- correct type of licence - E.&&. (nowaday `validQualification` qualUser) -- currently valid and not blocked + E.&&. (now `validQualification` qualUser) -- currently valid and not blocked ) `E.innerJoin` E.table @UserAvs `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser) diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index a59ac3bfe..6c27ba64f 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -25,11 +25,11 @@ mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQ qualificationUserBlockUnblock = False qualificationUserBlockBlocker = Nothing --- No longer possible, needs all QualificationUserBlocks to decide! Easy to work without --- isValidQualification :: HasQualificationUser a => Day -> a -> Bool --- isValidQualification d q = d `inBetween` (q ^. hasQualificationUser . _qualificationUserFirstHeld --- ,q ^. hasQualificationUser . _qualificationUserValidUntil) --- && isNothing (q ^. hasQualificationUser . _qualificationUserBlockedDue) +-- somewhat dangerous, if not used with latest effective block +isValidQualification :: (HasQualificationUser a, HasQualificationUserBlock b) => Day -> a -> Maybe b -> Bool +isValidQualification d qu qb= d `inBetween` (qu ^. hasQualificationUser . _qualificationUserFirstHeld + ,qu ^. hasQualificationUser . _qualificationUserValidUntil) + && all (^. hasQualificationUserBlock . _qualificationUserBlockUnblock) qb ------------------ -- SQL Snippets -- diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 88abb91b7..879358cf2 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) type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles ! @@ -151,6 +151,12 @@ csvCell route = anchorCell route iconFileCSV modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget content) +-- | Show Text if it is small, create modal otherwise +modalCellLarge :: (IsDBTable m a, ToWidget UniWorX t, MonoFoldable t, Element t ~ Char) => t -> DBCell m a +modalCellLarge content + | length content > 32 = modalCell content + | otherwise = textCell content + markupCellLargeModal :: IsDBTable m a => StoredMarkup -> DBCell m a markupCellLargeModal mup | markupIsSmallish mup = cell $ toWidget mup @@ -326,8 +332,29 @@ qualificationValidUntilCell q = textCell (qsh <> ": ") <> dayCell vtd qsh = q ^. hasQualification . _qualificationShorthand . _CI vtd = q ^. hasQualificationUser . _qualificationUserValidUntil --- qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a) => Day -> a -> DBCell m c --- qualificationValidIconCell = (iconBoolCell .) . isValidQualification +qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> a -> Maybe b -> DBCell m c +qualificationValidIconCell d qu qb = iconBoolCell $ isValidQualification d qu qb + +qualificationValidReasonCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Bool -> Day -> a -> Maybe b -> DBCell m c +qualificationValidReasonCell showReason d qu qb = ic <> foldMap blc qb + where + ic = iconBoolCell $ isValidQualification d qu qb + blc (view hasQualificationUserBlock -> QualificationUserBlock{..}) + | showReason = spacerCell <> dateCell qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason + -- TODO: add anchorLink to block history, if user is allowed + | qualificationUserBlockUnblock = mempty + | otherwise = spacerCell <> dateCell qualificationUserBlockFrom + +-- qualificationBlockedCellNoReason :: IsDBTable m a => QualificationUserBlock -> DBCell m a +-- qualificationBlockedCellNoReason QualificationUserBlock{qualificationUserBlockFrom=t, qualificationUserBlockUnblock=unblock} = +-- iconBoolCell unblock <> spacerCell <> dateCell d + +-- qualificationBlockedCell :: IsDBTable m a => QualificationUserBlock -> DBCell m a +-- qualificationBlockedCell QualificationUserBlock{..} +-- | 32 >= length qualificationUserBlockReason = mkCellWith textCell +-- | otherwise = mkCellWith modalCell +-- where +-- mkCellWith c = c qualificationUserBlockReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationUserBlockFrom lmsShortCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name @@ -376,20 +403,6 @@ lmsStatusCell extendedInfo (Just toLink) lu = cell $ do uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser modal (lmsUserStatusWidget extendedInfo lu) (Left $ SomeRoute $ toLink uuid) --- TODO: rework this below once it is clear what we need instead --- qualificationBlockedCellNoReason :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a --- qualificationBlockedCellNoReason Nothing = mempty --- qualificationBlockedCellNoReason (Just QualificationBlocked{qualificationBlockedDay=d}) = --- iconCell IconBlocked <> spacerCell <> dayCell d --- TODO: rework this below once it is clear what we need instead --- qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a --- qualificationBlockedCell Nothing = mempty --- qualificationBlockedCell (Just QualificationBlocked{..}) --- | 32 >= length qualificationBlockedReason = mkCellWith textCell --- | otherwise = mkCellWith modalCell --- where --- mkCellWith c = c qualificationBlockedReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationBlockedDay - avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c avsPersonNoCell = numCell . view _userAvsNoPerson diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index a633c983a..0a701784e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -71,7 +71,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.&&. quser E.^. QualificationUserScheduleRenewal E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate - E.&&. (quser `qualificationValid` nowaday) + E.&&. (quser `qualificationValid` now) E.&&. E.notExists (do luser <- E.from $ E.table @LmsUser E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid @@ -151,7 +151,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification) E.where_ $ E.isNothing (luser E.^. LmsUserStatus) E.&&. E.isNothing (luser E.^. LmsUserEnded) - E.&&. E.not_ (validQualification nowaday quser) + E.&&. E.not_ (validQualification now quser) pure (luser E.^. LmsUserId) nrExpired <- E.updateCount $ \luser -> do E.set luser [LmsUserStatus E.=. E.justVal (LmsExpired nowaday)] @@ -160,9 +160,9 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act notifyInvalidDrivers <- E.select $ do quser <- E.from $ E.table @QualificationUser - E.where_ $ E.not_ (quser `qualificationValid` nowaday) -- currently invalid + E.where_ $ E.not_ (quser `qualificationValid` now) -- currently invalid E.&&. quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification - E.&&. quser `quserToNotify` nowaday -- recently became invalid or blocked + E.&&. quser `quserToNotify` now -- recently became invalid or blocked pure (quser E.^. QualificationUserUser) forM_ notifyInvalidDrivers $ \(E.Value uid) -> diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index 1f0435857..22dadc99d 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -54,10 +54,10 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do case dbRes of ( Just User{..}, Just Qualification{..}, Just (Entity quId QualificationUser{..})) -> do now <- liftIO getCurrentTime - qub_entry <- runDB $ selectRelevantBlock now quId - let block = find (not . qualificationUserBlockUnblock) qub_entry + qub_entry <- entityVal <<$>> runDB (selectRelevantBlock now quId) + let block = filterMaybe (not . qualificationUserBlockUnblock) qub_entry urender <- getUrlRender - let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . qualificationUserBlockFrom) block + let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . utctDay . qualificationUserBlockFrom) block qname = CI.original qualificationName qshort = CI.original qualificationShorthand letter = LetterExpireQualificationF @@ -76,8 +76,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do then do notifyOk <- sendEmailOrLetter jRecipient letter if notifyOk - then do - now <- liftIO getCurrentTime + then do runDB $ update quId [QualificationUserLastNotified =. now] $logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname else diff --git a/src/Utils.hs b/src/Utils.hs index 9357d32cd..9b3390c5c 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -870,10 +870,10 @@ deepAlt altFst _ = altFst maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m maybeEmpty = flip foldMap --- Use instead the more general `find :: Foldable t => (a -> Bool) -> t a -> Maybe a` --- filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a --- filterMaybe c r@(Just x) | c x = r --- filterMaybe _ _ = Nothing +-- The more general `find :: Foldable t => (a -> Bool) -> t a -> Maybe a` +filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a +filterMaybe c r@(Just x) | c x = r +filterMaybe _ _ = Nothing -- | also referred to as whenJust whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 92e76ee4b..9c3791c30 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -162,8 +162,11 @@ instance HasQualification a => HasQualification (a,b) where instance HasQualificationUser a => HasQualificationUser (Entity a) where hasQualificationUser = _entityVal . hasQualificationUser -instance HasQualificationUser a => HasQualificationUser (b,a) where - hasQualificationUser = _2 . hasQualificationUser +-- instance HasQualificationUser a => HasQualificationUser (b,a) where +-- hasQualificationUser = _2 . hasQualificationUser + +instance HasQualificationUserBlock a => HasQualificationUserBlock (Entity a) where + hasQualificationUser = _entityVal . hasQualificationUserBlock instance HasLmsUser a => HasLmsUser (Entity a) where hasLmsUser = _entityVal . hasLmsUser