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

chore(qualification): block expired qualification users explicitly

Browse Source
This commit is contained in:
Steffen Jost 2023-10-06 11:16:49 +00:00
parent f776aaaef5
commit e3b6a7e4c6
4 changed files with 26 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -201,7 +201,7 @@ renewValidQualificationUsers qid renewalTime uids =
return $ length quEnts
_ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.
-- | Block or unblock some users for a given reason
-- | Block or unblock some users for a given reason, but only if they are not already blocked (essential assumption that is actually used)
qualificationUserBlocking ::
( AuthId (HandlerSite m) ~ Key User
, IsPersistBackend (YesodPersistBackend (HandlerSite m))

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

@ -189,24 +189,28 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
$logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort
now <- liftIO getCurrentTime
-- end users that expired by doing nothing
expiredLearners <- E.select $ do
expiredUsers <- E.select $ do
(quser :& luser) <- E.from $
E.table @QualificationUser
`E.innerJoin` E.table @LmsUser
`E.leftJoin` E.table @LmsUser
`E.on` (\(quser :& luser) ->
luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification)
luser E.?. LmsUserUser E.?=. quser E.^. QualificationUserUser
E.&&. luser E.?. LmsUserQualification E.?=. quser E.^. QualificationUserQualification)
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
E.&&. luser E.^. LmsUserQualification E.==. E.val qid
E.&&. E.isNothing (luser E.^. LmsUserStatus)
-- E.&&. luser E.?. LmsUserQualification E.?=. E.val qid
-- E.&&. E.isNothing (luser E.^. LmsUserStatus)
-- E.&&. E.isNothing (luser E.^. LmsUserEnded)
E.&&. E.not_ (validQualification now quser)
pure (luser E.^. LmsUserId)
pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser)
nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once
let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ]
-- let expiredLearners = catMaybes (E.unValue . fst <$> expiredUsers)
nrExpired <- E.updateCount $ \luser -> do
E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal now]
E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners)
E.where_ $ E.isNothing (luser E.^. LmsUserStatus)
E.&&. luser E.^. LmsUserQualification E.==. E.val qid
$logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
E.&&. (luser E.^. LmsUserId) `E.in_` E.valList expiredLearners
$logInfoS "LMS" $ "Expired qualification holders " <> tshow nrBlocked <> " and expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers
notifyInvalidDrivers <- E.select $ do

2
src/Model/Types/Lms.hs
View File

@ -59,11 +59,13 @@ instance Csv.ToField LmsStatus where
data QualificationBlockStandardReason
= QualificationBlockFailedELearning
| QualificationBlockReturnedByCompany
| QualificationBlockExpired
deriving (Eq, Ord, Enum, Bounded, Universe, Finite)
instance Show QualificationBlockStandardReason where
show QualificationBlockFailedELearning = "E-Learning durchgefallen"
show QualificationBlockReturnedByCompany = "Rückgabe Firma"
show QualificationBlockExpired = "Abgelaufen"
qualificationBlockedReasonText :: QualificationBlockStandardReason -> Text
qualificationBlockedReasonText =

18
test/Database/Fill.hs
View File

@ -726,16 +726,18 @@ fillDb = do
qidfUsers <- Set.fromAscList . fmap (qualificationUserUser . entityVal)
<$> selectList [QualificationUserQualification ==. qid_f] [Asc QualificationUserUser]
insertMany_ [QualificationUser uid qid_f (n_day (fromIntegral (length udn) - 12)) (n_day $ -42) (n_day $ -365) True (n_day' $ -11)| Entity uid User{userDisplayName=udn} <- take 200 matUsers, uid `Set.notMember` qidfUsers]
void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now
insertMany_ [QualificationUser uid qid_f (n_day (fromIntegral (length udn) - 12)) (n_day $ -42) (n_day $ -365) True (n_day' $ -11) | Entity uid User{userDisplayName=udn} <- take 200 $ drop 2 matUsers, uid `Set.notMember` qidfUsers]
insertMany_ [LmsUser qid_f uid (LmsIdent udn) "123456" False now astatus astatusDay now (Just now) (Just now) Nothing False False | Entity uid User{userDisplayName=udn} <- take 200 $ drop 22 matUsers, uid `Set.notMember` qidfUsers
, let selsome = odd $ length udn, let astatus = bool Nothing (Just LmsBlocked) selsome, let astatusDay = bool Nothing (Just now) selsome]
void . insert' $ LmsResult qid_f (LmsIdent "hijklm" ) (n_day (-1)) now
void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now
void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now
void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now
void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now
void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now
void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) False False
void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day' 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing True False
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just LmsBlocked) (Just $ now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True
void . insert' $ LmsUserlist qid_f (LmsIdent "hijklm") False now
void . insert' $ LmsUserlist qid_f (LmsIdent "abcdef") True now
void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now
void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) False False
void . insert' $ LmsUser qid_f svaupel (LmsIdent "bcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day' 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing True False
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hiklmn") "@#!" True now (Just LmsBlocked) (Just $ now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True
void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just LmsSuccess) (Just $ n_day' (-22)) (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing True True
void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just LmsBlocked) (Just $ n_day' (-11)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing True True
void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing Nothing now Nothing Nothing Nothing False False