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

Merge branch 'fradrive/localmaster'

Browse Source
This commit is contained in:
Steffen Jost 2023-03-28 14:58:57 +00:00
commit edc5d72734
3 changed files with 35 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/Handler/Utils/Profile.hs
View File

@ -82,12 +82,12 @@ validPostAddress _ = False
-- also see `Handler.Utils.Users.getEmailAddress` for Tests accepting User Type
validEmail :: Email -> Bool -- Email = Text
validEmail email = validRFC5322 -- && not invalidFraport
validEmail email = validRFC5322 && not invalidFraport
where
validRFC5322 = Email.isValid $ encodeUtf8 email
-- invalidFraport = case Text.stripSuffix "@fraport.de" email of
-- Just fralogin -> all isDigit $ drop 1 fralogin
-- Nothing -> False
invalidFraport = case Text.stripSuffix "@fraport.de" email of
Just fralogin -> all isDigit $ drop 1 fralogin
Nothing -> False
validEmail' :: UserEmail -> Bool -- UserEmail = CI Text
validEmail' = validEmail . CI.original

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

@ -222,14 +222,14 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
&& qualificationUserLastRefresh <= utctDay lmsUserStarted
newStatus = LmsSuccess lmsResultSuccess
newStatus = Just $ LmsSuccess lmsResultSuccess
-- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
note <- if saneDate && isLmsSuccess newStatus
note <- if saneDate && replaceLmsStatus lmsUserStatus newStatus
then do
_ok <- renewValidQualificationUsers qid [qualificationUserUser] -- blocked is unaffected
_ok <- renewValidQualificationUsers qid [qualificationUserUser] -- blocked remains unaffected
-- when (ok==1) $ update luid -- we end lms regardless of wether a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings
update luid
[ LmsUserStatus =. Just newStatus
[ LmsUserStatus =. newStatus
, LmsUserReceived =. Just lmsResultTimestamp
]
-- WORKAROUND LMS-Bug [supposedly fixed now]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
@ -277,32 +277,35 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
| otherwise -> return () -- users likely not yet started
(Entity luid luser, Just (Entity lulid lulist)) -> do
let lReceived = lmsUserlistTimestamp lulist
lmsMsgDay = utctDay lReceived
update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications
-- $logInfoS "LmsUserlist" $ tshow lulist
when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available
queueDBJob JobSendNotification
{ jRecipient = lmsUserUser luser
, jNotification = NotificationQualificationRenewal { nQualification = qid }
}
let lReceived = lmsUserlistTimestamp lulist
isBlocked = lmsUserlistFailed lulist
update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotfied is only updated upon sending notifications
$logInfoS "LmsUserlist" $ tshow lulist
when isBlocked $ do
let blockedDay = utctDay lReceived
newStatus = LmsBlocked blockedDay
oldStatus = lmsUserStatus luser
let isBlocked = lmsUserlistFailed lulist
oldStatus = lmsUserStatus luser
newStatus = bool Nothing (Just $ LmsBlocked lmsMsgDay) isBlocked
updateStatus = replaceLmsStatus oldStatus newStatus
when updateStatus $ do
audit TransactionLmsBlocked
{ transactionQualification = qid
, transactionLmsIdent = lmsUserIdent luser
, transactionLmsDay = blockedDay
, transactionLmsDay = lmsMsgDay
, transactionLmsUser = Just $ lmsUserUser luser
, transactionNote = Just $ "Old status was " <> tshow oldStatus
, transactionReceived = lReceived
}
update luid [LmsUserStatus =. (oldStatus <> Just newStatus)]
void $ qualificationUserBlocking qid [lmsUserUser luser] $ Just $ mkQualificationBlocked QualificationBlockFailedELearning blockedDay
update luid [LmsUserStatus =. newStatus]
void $ qualificationUserBlocking qid [lmsUserUser luser] $ Just $ mkQualificationBlocked QualificationBlockFailedELearning lmsMsgDay
queueDBJob JobSendNotification
{ jRecipient = lmsUserUser luser
, jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = blockedDay }
, jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = lmsMsgDay }
}
delete lulid

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

@ -55,6 +55,18 @@ isLmsSuccess :: LmsStatus -> Bool
isLmsSuccess LmsSuccess{} = True
isLmsSuccess _other = False
isLmsExpired :: LmsStatus -> Bool
isLmsExpired LmsExpired{} = True
isLmsExpired _other = False
-- | What to do if LMS sends multiple responses and whether an oldStatus should be overwritten
replaceLmsStatus :: Maybe LmsStatus -> Maybe LmsStatus -> Bool
replaceLmsStatus _ Nothing = False
replaceLmsStatus Nothing _ = True
replaceLmsStatus (Just LmsSuccess{}) _ = False
replaceLmsStatus (Just LmsExpired{}) (Just newStat) = not $ isLmsExpired newStat
replaceLmsStatus (Just LmsBlocked{}) (Just newStat) = isLmsSuccess newStat
makeLenses_ ''LmsStatus
-- Entscheidung 16.09.22: Es gewinnt was zuerst gemeldet wurde. Das verhindert, dass eine Qualifikation doppelt verlängert wird! Siehe Model.TypesSpec