fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(qualifications): suggestions for qualification view block acts (WIP)

Browse Source
This commit is contained in:
Steffen Jost 2023-06-26 16:28:17 +00:00
parent a28fb72021
commit 878f98604c
11 changed files with 120 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/categories/qualification/de-de-formal.msg
View File

@ -24,7 +24,7 @@ TableQualificationLastNotified: Letzte Benachrichtigung
TableQualificationFirstHeld: Erstmalig TableQualificationFirstHeld: Erstmalig
TableQualificationBlockedDue: Entzogen TableQualificationBlockedDue: Entzogen
TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst? 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 TableQualificationNoRenewal: Auslaufend
TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch weiterhin gültig sein. 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? QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls diese Qualikation bald ablaufen sollte?

2
messages/uniworx/categories/qualification/en-eu.msg
View File

@ -24,7 +24,7 @@ TableQualificationLastNotified: Last notified
TableQualificationFirstHeld: First held TableQualificationFirstHeld: First held
TableQualificationBlockedDue: Revoked TableQualificationBlockedDue: Revoked
TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended? 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 TableQualificationNoRenewal: Discontinued
TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid. 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? QualificationScheduleRenewalTooltip: Will there be a notification, if this qualification is about to expire soon?

110
src/Handler/Qualification.hs
View File

@ -80,7 +80,7 @@ mkQualificationAllTable isAdmin = do
Ex.where_ $ filterSvs quser Ex.where_ $ filterSvs quser
cactive = Ex.subSelectCount $ do cactive = Ex.subSelectCount $ do
quser <- Ex.from $ Ex.table @QualificationUser 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) return (quali, cactive, cusers)
dbtRowKey = (Ex.^. QualificationId) dbtRowKey = (Ex.^. QualificationId)
dbtProj = dbtProjId dbtProj = dbtProjId
@ -152,7 +152,7 @@ data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
, qtcCompanyNumbers :: CsvSemicolonList Int , qtcCompanyNumbers :: CsvSemicolonList Int
, qtcValidUntil :: Day , qtcValidUntil :: Day
, qtcLastRefresh :: Day , qtcLastRefresh :: Day
, qtcBlocked :: Maybe Day , qtcBlocked :: Maybe UTCTime
, qtcScheduleRenewal:: Bool , qtcScheduleRenewal:: Bool
, qtcLmsStatusTxt :: Maybe Text , qtcLmsStatusTxt :: Maybe Text
, qtcLmsStatusDay :: Maybe Day , qtcLmsStatusDay :: Maybe Day
@ -225,7 +225,7 @@ queryLmsUser = $(sqlLOJproj 3 2)
queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
queryQualBlock = $(sqlLOJproj 3 3) 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 :: Lens' QualificationTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1 resultQualUser = _dbrOutput . _1
@ -236,11 +236,11 @@ resultUser = _dbrOutput . _2
resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser) resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser)
resultLmsUser = _dbrOutput . _3 . _Just resultLmsUser = _dbrOutput . _3 . _Just
resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
resultCompanyUser = _dbrOutput . _4
resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock) 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 instance HasEntity QualificationTableData User where
@ -277,12 +277,10 @@ data QualificationTableActionData
| QualificationActUnexpireData | QualificationActUnexpireData
| QualificationActBlockSupervisorData | QualificationActBlockSupervisorData
| QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
-- idea: implement some standard answers in addition to a free form answer | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool}
| QualificationActBlockData { qualTableActBlockStandard :: QualificationBlockStandardReason, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
| QualificationActUnblockData
| QualificationActRenewData | QualificationActRenewData
| QualificationActGrantData { qualTableActGrantUntil :: Day } | QualificationActGrantData { qualTableActGrantUntil :: Day }
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Show, Generic)
isExpiryAct :: QualificationTableActionData -> Bool isExpiryAct :: QualificationTableActionData -> Bool
isExpiryAct QualificationActExpireData = True isExpiryAct QualificationActExpireData = True
@ -292,7 +290,7 @@ isExpiryAct _ = False
isBlockAct :: QualificationTableActionData -> Bool isBlockAct :: QualificationTableActionData -> Bool
isBlockAct QualificationActBlockSupervisorData = True isBlockAct QualificationActBlockSupervisorData = True
isBlockAct QualificationActBlockData{} = True isBlockAct QualificationActBlockData{} = True
isBlockAct QualificationActUnblockData = True isBlockAct QualificationActUnblockData{} = True
isBlockAct _ = False isBlockAct _ = False
blockActRemoveSupervisors :: QualificationTableActionData -> Bool blockActRemoveSupervisors :: QualificationTableActionData -> Bool
@ -328,10 +326,10 @@ qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin`
E.where_ $ fltr qualUser E.where_ $ fltr qualUser
E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
E.&&. E.notExists (E.from $ \earlierBlock -> E.&&. E.notExists (E.from $ \earlierBlock ->
E.where_ $ earlierBlock E.^. QualificationUserBlockId E.!=. qualBlock E.^. QualificationUserBlockId E.where_ $ earlierBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
E.&&. earlierBlock E.^. QualificationUserBlockFrom E.>. qualBlock E.^. QualificationUserBlockFrom E.&&. E.just (earlierBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom
) )
return (qualUser, user, lmsUser) return (qualUser, user, lmsUser, qualBlock)
mkQualificationTable :: 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 fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
dbtSQLQuery = qualificationTableQuery qid fltrSvs dbtSQLQuery = qualificationTableQuery qid fltrSvs
dbtRowKey = queryUser >>> (E.^. UserId) 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 -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do
-- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId -- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
-- E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr) -- E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr)
-- E.orderBy [E.asc (comp E.^. CompanyName)] -- E.orderBy [E.asc (comp E.^. CompanyName)]
-- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor) -- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor)
cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
return (qualUsr, usr, lmsUsr, cmpUsr) return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr)
dbtColonnade = cols cmpMap dbtColonnade = cols cmpMap
dbtSorting = mconcat dbtSorting = mconcat
[ single $ sortUserNameLink queryUser [ single $ sortUserNameLink queryUser
@ -376,7 +374,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) , 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}" , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
, queryLmsUser row E.?. LmsUserStarted]) , queryLmsUser row E.?. LmsUserStarted])
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) , 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)] E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName) return (comp E.^. CompanyName)
) )
, single ("validity", SortColumn $ queryQualUser >>> validQualification nowaday) -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now)
] ]
dbtFilter = mconcat dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser [ 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.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit 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 -> , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
if | Just renewal <- mbRenewal if | Just renewal <- mbRenewal
, Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal , 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 resultCompanyUser >>= getCompanyNos)
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)
<*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
<*> getStatusPlusTxt <*> getStatusPlusTxt
<*> getStatusPlusDay <*> getStatusPlusDay
@ -510,32 +508,53 @@ postQualificationR sid qsh = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let nowaday = utctDay now let nowaday = utctDay now
((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
qent@Entity{entityVal=Qualification{ qent@Entity{
qualificationAuditDuration=auditMonths entityKey=qid
, qualificationValidDuration=validMonths , entityVal=Qualification{
qualificationAuditDuration=auditMonths
, qualificationValidDuration=validMonths
}} <- getBy404 $ SchoolQualificationShort sid qsh }} <- 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 :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
acts = mconcat $ acts = mconcat $
[ singletonMap QualificationActExpire $ pure QualificationActExpireData [ singletonMap QualificationActExpire $ pure QualificationActExpireData
, singletonMap QualificationActUnexpire $ QualificationActUnexpireData , singletonMap QualificationActUnexpire $ QualificationActUnexpireData
<$ aformMessage msgUnexpire <$ aformMessage msgUnexpire
] ++ bool ] ++ bool
[ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin actions, ie. Supervisor -- nonAdmin actions, ie. Supervisor
[ singletonMap QualificationActUnblock $ pure QualificationActUnblockData -- Admin-only actions [ 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 , singletonMap QualificationActBlock $ QualificationActBlockData
<$> apreq textField (fslI MsgQualificationBlockReason) Nothing <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False) <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False)
, singletonMap QualificationActRenew $ pure QualificationActRenewData , singletonMap QualificationActRenew $ pure QualificationActRenewData
, singletonMap QualificationActGrant $ QualificationActGrantData , singletonMap QualificationActGrant $ QualificationActGrantData
<$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
<* aformMessage msgGrantWarning <* aformMessage msgGrantWarning
] isAdmin ] isAdmin
linkLmsUser = toMaybe isAdmin LmsUserR linkLmsUser = toMaybe isAdmin LmsUserR
linkUserName = bool ForProfileR ForProfileDataR isAdmin linkUserName = bool ForProfileR ForProfileDataR isAdmin
blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin
colChoices cmpMap = mconcat colChoices cmpMap = mconcat
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, colUserNameModalHdr MsgLmsUser linkUserName , colUserNameModalHdr MsgLmsUser linkUserName
@ -550,11 +569,11 @@ postQualificationR sid qsh = do
(\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
in wgtCell companies in wgtCell companies
, guardMonoid isAdmin colUserMatriclenr , 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 "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil))
, 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 "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> blockedDueCell b qualificationValidReasonCell isAdmin nowaday (row ^. resultQualUser) (row ^? resultQualBlock)
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
, sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) , 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 addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
reloadKeepGetParams $ QualificationR sid qsh reloadKeepGetParams $ QualificationR sid qsh
(QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do (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 addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
reloadKeepGetParams $ QualificationR sid qsh reloadKeepGetParams $ QualificationR sid qsh
(action, selectedUsers) | isExpiryAct action -> do (action, selectedUsers) | isExpiryAct action -> do
@ -585,29 +604,24 @@ postQualificationR sid qsh = do
reloadKeepGetParams $ QualificationR sid qsh reloadKeepGetParams $ QualificationR sid qsh
(action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
let selUserIds = Set.toList selectedUsers let selUserIds = Set.toList selectedUsers
qubr = case action of (unblock, reason) = case action of
QualificationActUnblockData -> Nothing QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany)
QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday QualificationActBlockData{..} -> (False, Left qualTableActBlockReason)
QualificationActBlockData{..} -> Just $ QualificationBlocked QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason)
{ qualificationBlockedDay = nowaday _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks
, qualificationBlockedReason = qualTableActBlockReason
}
_ -> error "Handle.Qualification.isBlockAct returned non-block action"
notify = case action of notify = case action of
QualificationActBlockData{qualTableActNotify} -> qualTableActNotify QualificationActBlockData{qualTableActNotify} -> qualTableActNotify
_ -> False _ -> False
oks <- runDB $ do oks <- runDB $ do
when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds] when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds]
qualificationUserBlocking qid selUserIds notify qubr qualificationUserBlocking qid selUserIds unblock reason notify
let nrq = length selectedUsers let nrq = length selectedUsers
warnLevel = if warnLevel = if
| oks < 0 -> Error | oks < 0 -> Error
| oks == nrq -> Success | oks == nrq -> Success
| otherwise -> Warning | otherwise -> Warning
fbmsg = if fbmsg = if unblock then MsgQualificationStatusUnblock else MsgQualificationStatusBlock
| isNothing qubr -> MsgQualificationStatusUnblock
| otherwise -> MsgQualificationStatusBlock
addMessageI warnLevel $ fbmsg qsh oks nrq addMessageI warnLevel $ fbmsg qsh oks nrq
reloadKeepGetParams $ QualificationR sid qsh reloadKeepGetParams $ QualificationR sid qsh
_ -> addMessageI Error MsgInvalidFormAction _ -> addMessageI Error MsgInvalidFormAction

2
src/Handler/Tutorial/Form.hs
View File

@ -90,7 +90,7 @@ tutorialForm cid template html = do
<*> tutorForm <*> tutorForm
where where
tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text)) 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 fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
return $ tutorial E.^. TutorialType return $ tutorial E.^. TutorialType

5
src/Handler/Utils/Avs.hs
View File

@ -259,8 +259,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
--let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences --let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences
-- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld -- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld
-- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either -- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either
let nowaday = utctDay now let vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences
vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences
rollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld' rollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld'
vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld' vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld'
rollfeld = Set.map avsLicencePersonID rollfeld' rollfeld = Set.map avsLicencePersonID rollfeld'
@ -275,7 +274,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
(quali E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification) (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! -- 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.&&. (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.innerJoin` E.table @UserAvs
`E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser) `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)

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

@ -25,11 +25,11 @@ mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQ
qualificationUserBlockUnblock = False qualificationUserBlockUnblock = False
qualificationUserBlockBlocker = Nothing qualificationUserBlockBlocker = Nothing
-- No longer possible, needs all QualificationUserBlocks to decide! Easy to work without -- somewhat dangerous, if not used with latest effective block
-- isValidQualification :: HasQualificationUser a => Day -> a -> Bool isValidQualification :: (HasQualificationUser a, HasQualificationUserBlock b) => Day -> a -> Maybe b -> Bool
-- isValidQualification d q = d `inBetween` (q ^. hasQualificationUser . _qualificationUserFirstHeld isValidQualification d qu qb= d `inBetween` (qu ^. hasQualificationUser . _qualificationUserFirstHeld
-- ,q ^. hasQualificationUser . _qualificationUserValidUntil) ,qu ^. hasQualificationUser . _qualificationUserValidUntil)
-- && isNothing (q ^. hasQualificationUser . _qualificationUserBlockedDue) && all (^. hasQualificationUserBlock . _qualificationUserBlockUnblock) qb
------------------ ------------------
-- SQL Snippets -- -- SQL Snippets --

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

@ -14,7 +14,7 @@ import Handler.Utils.DateTime
import Handler.Utils.Widgets import Handler.Utils.Widgets
import Handler.Utils.Occurrences import Handler.Utils.Occurrences
import Handler.Utils.LMS (lmsUserStatusWidget) import Handler.Utils.LMS (lmsUserStatusWidget)
-- import Handler.Utils.Qualification (isValidQualification) import Handler.Utils.Qualification (isValidQualification)
type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles ! 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 :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a
modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget content) 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 :: IsDBTable m a => StoredMarkup -> DBCell m a
markupCellLargeModal mup markupCellLargeModal mup
| markupIsSmallish mup = cell $ toWidget mup | markupIsSmallish mup = cell $ toWidget mup
@ -326,8 +332,29 @@ qualificationValidUntilCell q = textCell (qsh <> ": ") <> dayCell vtd
qsh = q ^. hasQualification . _qualificationShorthand . _CI qsh = q ^. hasQualification . _qualificationShorthand . _CI
vtd = q ^. hasQualificationUser . _qualificationUserValidUntil vtd = q ^. hasQualificationUser . _qualificationUserValidUntil
-- qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a) => Day -> a -> DBCell m c qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> a -> Maybe b -> DBCell m c
-- qualificationValidIconCell = (iconBoolCell .) . isValidQualification 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 :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name lmsShortCell (view hasQualification -> Qualification{..}) = anchorCell link name
@ -376,20 +403,6 @@ lmsStatusCell extendedInfo (Just toLink) lu = cell $ do
uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser
modal (lmsUserStatusWidget extendedInfo lu) (Left $ SomeRoute $ toLink uuid) 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 :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
avsPersonNoCell = numCell . view _userAvsNoPerson avsPersonNoCell = numCell . view _userAvsNoPerson

8
src/Jobs/Handler/LMS.hs
View File

@ -71,7 +71,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
E.&&. quser E.^. QualificationUserScheduleRenewal E.&&. quser E.^. QualificationUserScheduleRenewal
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
E.&&. (quser `qualificationValid` nowaday) E.&&. (quser `qualificationValid` now)
E.&&. E.notExists (do E.&&. E.notExists (do
luser <- E.from $ E.table @LmsUser luser <- E.from $ E.table @LmsUser
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid 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.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification)
E.where_ $ E.isNothing (luser E.^. LmsUserStatus) E.where_ $ E.isNothing (luser E.^. LmsUserStatus)
E.&&. E.isNothing (luser E.^. LmsUserEnded) E.&&. E.isNothing (luser E.^. LmsUserEnded)
E.&&. E.not_ (validQualification nowaday quser) E.&&. E.not_ (validQualification now quser)
pure (luser E.^. LmsUserId) pure (luser E.^. LmsUserId)
nrExpired <- E.updateCount $ \luser -> do nrExpired <- E.updateCount $ \luser -> do
E.set luser [LmsUserStatus E.=. E.justVal (LmsExpired nowaday)] E.set luser [LmsUserStatus E.=. E.justVal (LmsExpired nowaday)]
@ -160,9 +160,9 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
notifyInvalidDrivers <- E.select $ do notifyInvalidDrivers <- E.select $ do
quser <- E.from $ E.table @QualificationUser 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 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) pure (quser E.^. QualificationUserUser)
forM_ notifyInvalidDrivers $ \(E.Value uid) -> forM_ notifyInvalidDrivers $ \(E.Value uid) ->

11
src/Jobs/Handler/SendNotification/Qualification.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de> -- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -54,10 +54,10 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do
case dbRes of case dbRes of
( Just User{..}, Just Qualification{..}, Just (Entity quId QualificationUser{..})) -> do ( Just User{..}, Just Qualification{..}, Just (Entity quId QualificationUser{..})) -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
qub_entry <- runDB $ selectRelevantBlock now quId qub_entry <- entityVal <<$>> runDB (selectRelevantBlock now quId)
let block = find (not . qualificationUserBlockUnblock) qub_entry let block = filterMaybe (not . qualificationUserBlockUnblock) qub_entry
urender <- getUrlRender urender <- getUrlRender
let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . qualificationUserBlockFrom) block let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . utctDay . qualificationUserBlockFrom) block
qname = CI.original qualificationName qname = CI.original qualificationName
qshort = CI.original qualificationShorthand qshort = CI.original qualificationShorthand
letter = LetterExpireQualificationF letter = LetterExpireQualificationF
@ -76,8 +76,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do
then do then do
notifyOk <- sendEmailOrLetter jRecipient letter notifyOk <- sendEmailOrLetter jRecipient letter
if notifyOk if notifyOk
then do then do
now <- liftIO getCurrentTime
runDB $ update quId [QualificationUserLastNotified =. now] runDB $ update quId [QualificationUserLastNotified =. now]
$logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname $logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname
else else

8
src/Utils.hs
View File

@ -870,10 +870,10 @@ deepAlt altFst _ = altFst
maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
maybeEmpty = flip foldMap maybeEmpty = flip foldMap
-- Use instead the more general `find :: Foldable t => (a -> Bool) -> t a -> Maybe a` -- The more general `find :: Foldable t => (a -> Bool) -> t a -> Maybe a`
-- filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a
-- filterMaybe c r@(Just x) | c x = r filterMaybe c r@(Just x) | c x = r
-- filterMaybe _ _ = Nothing filterMaybe _ _ = Nothing
-- | also referred to as whenJust -- | also referred to as whenJust
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()

7
src/Utils/Lens.hs
View File

@ -162,8 +162,11 @@ instance HasQualification a => HasQualification (a,b) where
instance HasQualificationUser a => HasQualificationUser (Entity a) where instance HasQualificationUser a => HasQualificationUser (Entity a) where
hasQualificationUser = _entityVal . hasQualificationUser hasQualificationUser = _entityVal . hasQualificationUser
instance HasQualificationUser a => HasQualificationUser (b,a) where -- instance HasQualificationUser a => HasQualificationUser (b,a) where
hasQualificationUser = _2 . hasQualificationUser -- hasQualificationUser = _2 . hasQualificationUser
instance HasQualificationUserBlock a => HasQualificationUserBlock (Entity a) where
hasQualificationUser = _entityVal . hasQualificationUserBlock
instance HasLmsUser a => HasLmsUser (Entity a) where instance HasLmsUser a => HasLmsUser (Entity a) where
hasLmsUser = _entityVal . hasLmsUser hasLmsUser = _entityVal . hasLmsUser