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

chore(lms): complete import jobs

Browse Source
This commit is contained in:
Steffen Jost 2022-03-25 17:40:37 +01:00
parent e30e7bd756
commit c7f734cfca
8 changed files with 65 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
models/lms.model
View File

@ -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!

9
src/Database/Esqueleto/Utils.hs
View File

@ -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

8
src/Handler/LMS/Result.hs
View File

@ -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

7
src/Handler/LMS/Userlist.hs
View File

@ -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

2
src/Handler/LMS/Users.hs
View File

@ -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
}
-}

4
src/Handler/Utils/LMS.hs
View File

@ -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

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

@ -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 ()
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|]

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

@ -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