102 lines
5.4 KiB
Haskell
102 lines
5.4 KiB
Haskell
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module Jobs.Handler.LMS
|
|
( dispatchJobLmsResults
|
|
, dispatchJobLmsUserlist
|
|
) where
|
|
|
|
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 -- for insertSelect variant
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
|
|
dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
|
|
dispatchJobLmsResults qid = JobHandlerAtomic act
|
|
where
|
|
-- act :: YesodJobDB UniWorX ()
|
|
act = hoist lift $ do
|
|
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
|
|
(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
|
|
return $ LmsUser E.<# E.val qid
|
|
E.<&> (luser E.^. LmsUserUser)
|
|
E.<&> (luser E.^. LmsUserIdent)
|
|
E.<&> (luser E.^. LmsUserPin)
|
|
E.<&> (luser E.^. LmsUserResetPin)
|
|
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 ->
|
|
[ 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
|
|
-}
|
|
-- 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_ $ 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 lreceived = lmsResultTimestamp lresult
|
|
lstatus = lmsResultSuccess lresult & LmsSuccess
|
|
-- always log success, since this is only transmitted once
|
|
update luid [ LmsUserStatus =. 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 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)
|
|
| isJust $ lmsUserReceived luser
|
|
, isNothing $ lmsUserEnded luser ->
|
|
update luid [LmsUserEnded =. Just now]
|
|
| otherwise -> return () -- likely not yet started
|
|
|
|
(Entity luid luser, Just (Entity lulid lulist)) -> do
|
|
let usrNoStat = isNothing $ lmsUserStatus luser
|
|
lBlocked = lmsUserlistFailed lulist
|
|
updStatus = lBlocked && usrNoStat -- only update empty status to blocked
|
|
lReceived = lmsUserlistTimestamp lulist
|
|
lStatus = LmsBlocked $ utctDay lReceived
|
|
update luid $ [ LmsUserStatus =. Just lStatus | updStatus ]
|
|
<> [ LmsUserReceived =. Just lReceived ]
|
|
when lBlocked . insert_ $ LmsAudit qid (lmsUserIdent luser) lStatus lReceived now -- always log blocked
|
|
delete lulid
|
|
|
|
$logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]
|