refactor(qualifications): suggestions for qualification view block acts (WIP)
This commit is contained in:
parent
a28fb72021
commit
878f98604c
@ -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?
|
||||
|
||||
@ -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?
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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 --
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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) ->
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ()
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user