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

chore(lms): account for local timezone in LMS communication

Browse Source
This commit is contained in:
Steffen Jost 2023-03-03 09:56:17 +00:00
parent 1d8188023f
commit 109e2373a4
3 changed files with 7 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
models/lms.model
View File

@ -131,7 +131,7 @@ LmsUserlist
LmsResult LmsResult
qualification QualificationId OnDeleteCascade OnUpdateCascade qualification QualificationId OnDeleteCascade OnUpdateCascade
ident LmsIdent ident LmsIdent
success Day success Day -- BEWARE: timezone is local as submitted by LMS
timestamp UTCTime default=now() timestamp UTCTime default=now()
UniqueLmsResult qualification ident -- required by DBTable UniqueLmsResult qualification ident -- required by DBTable
deriving Generic deriving Generic

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

@ -25,6 +25,7 @@ import qualified Database.Esqueleto.Utils as E
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Time.Zones as TZ
import Handler.Utils.DateTime import Handler.Utils.DateTime
import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries) import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries)
@ -202,12 +203,12 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
return (quser, luser, lresult) return (quser, luser, lresult)
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now
forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
-- three separate DB operations per result is not so nice. All within one transaction though. -- three separate DB operations per result is not so nice. All within one transaction though.
let nowadayP1 = succ $ utctDay now -- add one day to account for time synch problems let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted
lmsUserStartedDay = utctDay lmsUserStarted saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay)
saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1) && qualificationUserLastRefresh <= utctDay lmsUserStarted
&& qualificationUserLastRefresh <= lmsUserStartedDay
newStatus = LmsSuccess lmsResultSuccess newStatus = LmsSuccess lmsResultSuccess
newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
note <- if saneDate && isLmsSuccess newStatus note <- if saneDate && isLmsSuccess newStatus

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

@ -104,7 +104,7 @@ instance Csv.FromField LmsBool where
| i == "1" = pure $ LmsBool True | i == "1" = pure $ LmsBool True
| otherwise = mempty | otherwise = mempty
-- | LMS interface requires day format not compliant with iso8601 -- | LMS interface requires day format not compliant with iso8601; also LMS uses LOCAL TIMEZONE
newtype LmsDay = LmsDay { lms2day :: Day } newtype LmsDay = LmsDay { lms2day :: Day }
deriving (Eq, Ord, Read, Show, Generic) deriving (Eq, Ord, Read, Show, Generic)