From c7f734cfca80a0c5815a3a3132aeff0ddd952a04 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 25 Mar 2022 17:40:37 +0100 Subject: [PATCH] chore(lms): complete import jobs --- models/lms.model | 12 ++++----- src/Database/Esqueleto/Utils.hs | 9 +++++++ src/Handler/LMS/Result.hs | 8 +++--- src/Handler/LMS/Userlist.hs | 7 +++--- src/Handler/LMS/Users.hs | 2 +- src/Handler/Utils/LMS.hs | 4 +-- src/Jobs/Handler/LMS.hs | 43 +++++++++++++++++++++++++++------ src/Model/Types/Lms.hs | 6 ++--- 8 files changed, 65 insertions(+), 26 deletions(-) diff --git a/models/lms.model b/models/lms.model index 3a5bdd91e..437de5179 100644 --- a/models/lms.model +++ b/models/lms.model @@ -63,7 +63,7 @@ QualificationUser -- -- 2. REST GET User.csv: -- - where LmsUserReceived == Nothing \/ (LmsUserResetPin /\ LmsUserEnded == Nothing) - -- - delete-flag: isJust LmsUserSuccess + -- - delete-flag: isJust LmsUserStatus -- Note: REST means that LmsUserResetPin and LmsUserDelete remain unchanged by this GET request! -- -- 3. REST POST Userlist.csv: @@ -77,13 +77,13 @@ QualificationUser -- + if contained, set LmsUserReceived to Just now() -- + otherwise, set LmsUserEnded to Just now() -- - if LmsUserlistFailed: - -- + set LmsUserSuccess to Just False + -- + set LmsUserStatus to Just Day -- + set LmsUserDelete to True -- - move row to LmsAudit -- -- 6. Daily Job LmsResult: -- - set LmsUserReceived to Just now() - -- - set LmsUserSuccess to Just True + -- - set LmsUserStatus to Just Day -- - move row to LmsAudit @@ -92,10 +92,10 @@ LmsUser user UserId ident LmsIdent -- must be unique accross all LMS courses! pin Text - resetPin Bool default=false -- should pin be reset? - success LmsStatus Maybe -- open, success or failure; isJust indicates user will be deleted from LMS + resetPin Bool default=false -- should pin be reset? + status 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() + started UTCTime default=now() received UTCTime Maybe -- last acknowledgement by LMS ended UTCTime Maybe -- ident was deleted from LMS UniqueLmsUser ident -- idents must be unique accross all qualifications, since idents are global within LMS! diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index a2fcba4f8..88bfdc345 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -7,6 +7,7 @@ module Database.Esqueleto.Utils , isJust, alt , isInfixOf, hasInfix , strConcat, substring + , (=?.), (?=.) , or, and , any, all , subSelectAnd, subSelectOr @@ -91,6 +92,14 @@ justVal = E.val . Just justValList :: PersistField typ => [typ] -> E.SqlExpr (E.ValueList (Maybe typ)) justValList = E.valList . map Just +infixl 4 =?. +(=?.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) +(=?.) a b = E.just a E.==. b + +infixl 4 ?=. +(?=.) :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value Bool) +(?=.) a b = a E.==. E.just b + -- | Negation of `isNothing` which is missing isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) isJust = E.not_ . E.isNothing diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index a3184ea37..276468909 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -19,6 +19,8 @@ import qualified Data.Conduit.List as C import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E +import Jobs.Queue + data LmsResultTableCsv = LmsResultTableCsv { csvLRTident :: LmsIdent @@ -166,9 +168,9 @@ mkResultTable sid qsh qid = do } [ LmsResultSuccess =. lmsResultInsertSuccess actionData , LmsResultTimestamp =. now - ] - -- queueDBJob?? -- todo - -- audit + ] + -- audit $ Transaction.. (add to Audit.Types) + lift . queueDBJob $ JobLmsResults qid return $ LmsResultR sid qsh , dbtCsvRenderKey = const $ \case LmsResultInsertData{..} -> do -- TODO: i18n diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index ff951a518..2f71cfd7c 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -19,6 +19,7 @@ import qualified Data.Conduit.List as C import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E +import Jobs.Queue data LmsUserlistTableCsv = LmsUserlistTableCsv { csvLULident :: LmsIdent @@ -160,9 +161,9 @@ mkUserlistTable sid qsh qid = do [ LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False? , LmsUserlistTimestamp =. now - ] - -- queueDBJob?? -- todo - -- audit + ] + -- audit + lift $ queueDBJob $ JobLmsUserlist qid return $ LmsUserlistR sid qsh dbtCsvRenderKey = const $ \case LmsUserlistInsertData{..} -> do -- TODO: i18n diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index c544de358..e63e90c13 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -160,7 +160,7 @@ getLmsUsersDirectR sid qsh = do { csvLUTident = lmsuser Ex.^. LmsUserIdent , csvLUTpin = lmsuser Ex.^. LmsUserPin , csvLUTresetPin = LmsBool . Ex.unValue $ lmsuser Ex.^. LmsUserResetPin - , csvLUTdelete = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserSuccess) + , csvLUTdelete = LmsBool . Ex.unValue $ Ex.isNothing (lmsuser Ex.^. LmsUserEnded) Ex.&&. Ex.not_ (Ex.isNothing $ lmsuser Ex.^. LmsUserStatus) , csvLUTstaff = LmsBool False } -} diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index 43b849e24..e3244e507 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -75,10 +75,10 @@ getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime -- | Deceide whether LMS platform should delete an identifier lmsUserToDeleteExpr :: E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool) -lmsUserToDeleteExpr lmslist = E.isNothing (lmslist E.^. LmsUserEnded) E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserSuccess) +lmsUserToDeleteExpr lmslist = E.isNothing (lmslist E.^. LmsUserEnded) E.&&. E.not_ (E.isNothing $ lmslist E.^. LmsUserStatus) lmsUserToDelete :: LmsUser -> Bool -lmsUserToDelete LmsUser{lmsUserEnded, lmsUserSuccess} = isNothing lmsUserEnded && isJust lmsUserSuccess +lmsUserToDelete LmsUser{lmsUserEnded, lmsUserStatus} = isNothing lmsUserEnded && isJust lmsUserStatus _lmsUserToDelete :: Getter LmsUser Bool _lmsUserToDelete = to lmsUserToDelete diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index dd589c1e0..d27fa4c0f 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -11,7 +11,7 @@ import Import import qualified Database.Esqueleto.Experimental as E --import qualified Database.Esqueleto.Legacy as E -- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant --- import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.Utils as E dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX @@ -40,7 +40,7 @@ dispatchJobLmsResults qid = JobHandlerAtomic act E.<&> (luser E.^. LmsUserEnded) ) (\current _excluded -> - [ LmsUserSuccess E.=. current E.^. LmsUserSuccess, LmsUserReceived E.=. current E.^. LmsUserReceived ] -- I believe this list could just be empty, since excluded is not uses?! + [ LmsUserStatus E.=. current E.^. LmsUserStatus, LmsUserReceived E.=. current E.^. LmsUserReceived ] -- I believe this list could just be empty, since excluded is not uses?! ) -- Unclear how to delete here -} @@ -50,14 +50,14 @@ dispatchJobLmsResults qid = JobHandlerAtomic act 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 + E.where_ $ luser E.^. LmsUserQualification 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 + let lreceived = lmsResultTimestamp lresult + lstatus = lmsResultSuccess lresult & LmsSuccess + update luid [ LmsUserStatus =. Just lstatus , LmsUserReceived =. Just lreceived ] insert_ $ LmsAudit qid (lmsUserIdent luser) lstatus lreceived now @@ -65,4 +65,31 @@ dispatchJobLmsResults qid = JobHandlerAtomic act $logInfoS "LmsResult" [st|Processed ${tshow (length results)} LMS results|] dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX -dispatchJobLmsUserlist _qid = JobHandlerAtomic $ return () \ No newline at end of file +dispatchJobLmsUserlist qid = JobHandlerAtomic act + where + -- act :: YesodJobDB UniWorX () + act = hoist lift $ do + now <- liftIO getCurrentTime + -- result :: [(Entity LmsUser, Entity LmsUserlist)] + results <- E.select $ do + (luser E.:& lulist) <- E.from $ + E.table @LmsUser `E.leftJoin` E.table @LmsUserlist + `E.on` (\(luser E.:& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent + E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification) + E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid + E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners + return (luser, lulist) + forM_ results $ \case + (Entity luid _luser, Nothing) -> + update luid [LmsUserEnded =. Just now] + + (Entity luid luser, Just (Entity lulid lulist)) -> do + let lreceived = lmsUserlistTimestamp lulist + lblocked = lmsUserlistFailed lulist + lstatus = LmsBlocked $ utctDay lreceived + update luid $ [ LmsUserStatus =. Just lstatus | lblocked ] + <> [ LmsUserReceived =. Just lreceived ] + when lblocked . insert_ $ LmsAudit qid (lmsUserIdent luser) lstatus lreceived now + delete lulid + + $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|] diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index d2730d657..bec3aeaf2 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -33,10 +33,10 @@ data LmsStatus = LmsBlocked { lmsStatusDay :: Day } deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData) deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - , fieldLabelModifier = camelToPathPiece' 1 + { constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor, since the object is tagged with lms already + , fieldLabelModifier = camelToPathPiece' 2 -- just day suffices for the day field , omitNothingFields = True - , sumEncoding = TaggedObject "lmsaudit" "lmsaction" + , sumEncoding = TaggedObject "lms-status" "lms-result" } ''LmsStatus derivePersistFieldJSON ''LmsStatus