diff --git a/models/lms.model b/models/lms.model index c74b9d71f..3a5bdd91e 100644 --- a/models/lms.model +++ b/models/lms.model @@ -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 diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index a1291685f..dd589c1e0 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -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 () \ No newline at end of file diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 3a5ae6ea4..d2730d657 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -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 diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 9c66f5f58..0a7e5e406 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -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