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

chore(lms): complete dispatchJobLmsResults with persistent now

Browse Source
This commit is contained in:
Steffen Jost 2022-03-24 17:52:25 +01:00
parent 904e3ee044
commit ab45a719c3
4 changed files with 33 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
models/lms.model
View File

@ -93,8 +93,7 @@ LmsUser
ident LmsIdent -- must be unique accross all LMS courses!
pin Text
resetPin Bool default=false -- should pin be reset?
success Bool Maybe -- open, success or failure; isJust indicates user will be deleted from LMS
-- success LmsStatus -- this would also encode Day information?!
success LmsStatus Maybe -- open, success or failure; isJust indicates user will be deleted from LMS
--toDelete encoded by Handler.Utils.LMS.lmsUserToDelete
started UTCTime default=now()
received UTCTime Maybe -- last acknowledgement by LMS
@ -124,7 +123,7 @@ LmsResult
LmsAudit
qualification QualificationId
ident LmsIdent
notificationType LmsStatus -- LmsOpen | LmsBlocked | LmsSuccess Day
notificationType LmsStatus -- LmsBlocked Day | LmsSuccess Day
received UTCTime -- timestamp from LmsUserlist/LmsResult
processed UTCTime default=now()
deriving Generic

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

@ -10,8 +10,8 @@ import Import
-- import Jobs.Handler.Intervals.Utils
import qualified Database.Esqueleto.Experimental as E
--import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Utils as E
-- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant
-- import qualified Database.Esqueleto.Utils as E
dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
@ -19,7 +19,8 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
where
-- act :: YesodJobDB UniWorX ()
act = hoist lift $ do
_now <- liftIO getCurrentTime
now <- liftIO getCurrentTime
{- Unfortunately, we cannot use insertSelect due to Haskell-Type changes and deletion of keys
E.insertSelectWithConflict
(UniqueLmsUser $ error "insertSelectWithConflict inspected constraint") -- never executed, just a type hint
(do
@ -33,17 +34,35 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
E.<&> (luser E.^. LmsUserIdent)
E.<&> (luser E.^. LmsUserPin)
E.<&> (luser E.^. LmsUserResetPin)
E.<&> E.justVal True -- how to convert Day to LmsStatus here?
E.<&> (E.val $ (LmsSuccess . E.unValue) <$> (lresult E.^. LmsResultSuccess)) -- how to convert Day to LmsStatus here?
E.<&> (luser E.^. LmsUserStarted)
E.<&> E.just (lresult E.^. LmsResultTimestamp)
E.<&> (luser E.^. LmsUserEnded)
)
(\current _excluded ->
[ LmsUserSuccess E.=. E.justVal True, LmsUserReceived E.=. current E.^. LmsUserReceived ] -- I believe this list could just be empty, since excluded is not uses?!
[ LmsUserSuccess E.=. current E.^. LmsUserSuccess, LmsUserReceived E.=. current E.^. LmsUserReceived ] -- I believe this list could just be empty, since excluded is not uses?!
)
-- Unclear how to delete here
return ()
-}
-- result :: [(Entity LmsUser, Entity LmsResult)]
results <- E.select $ do
(luser E.:& lresult) <- E.from $
E.table @LmsUser `E.innerJoin` E.table @LmsResult
`E.on` (\(luser E.:& lresult) -> luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent
E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification)
E.where_ $ lresult E.^. LmsResultQualification E.==. E.val qid
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
return (luser, lresult)
forM_ results $ \(Entity luid luser, Entity lrid lresult) -> do
-- three separate DB operations per result is not so nice. All within one transaction though.
let lstatus = lmsResultSuccess lresult & LmsSuccess
lreceived = lmsResultTimestamp lresult
update luid [ LmsUserSuccess =. Just lstatus
, LmsUserReceived =. Just lreceived
]
insert_ $ LmsAudit qid (lmsUserIdent luser) lstatus lreceived now
delete lrid
$logInfoS "LmsResult" [st|Processed ${tshow (length results)} LMS results|]
dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX
dispatchJobLmsUserlist _qid = JobHandlerAtomic $ return ()

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

@ -27,8 +27,9 @@ deriveJSON defaultOptions
, omitNothingFields = True
} ''LmsIdent
-- TODO: is this a good idea? Maybe just an ordinary Enum and a separate Day Column in the DB would be better, especially since LmsBlocked should really also encode a Day
data LmsStatus = LmsOpen | LmsBlocked | LmsSuccess Day
-- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS?
data LmsStatus = LmsBlocked { lmsStatusDay :: Day }
| LmsSuccess { lmsStatusDay :: Day }
deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData)
deriveJSON defaultOptions

4
test/Database/Fill.hs
View File

@ -476,8 +476,8 @@ fillDb = do
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 Nothing now Nothing Nothing
void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False (Just True) now (Just now) Nothing
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True (Just False) now (Just now) Nothing
void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False (Just $ LmsSuccess $ utctDay now) now (Just now) Nothing
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True (Just $ LmsBlocked $ utctDay now) now (Just now) Nothing
let
sdBsc = StudyDegreeKey' 82