chore(lms): lmsstatus to semigroup for easy switch, lms notficiation stub
This commit is contained in:
Steffen Jost
parent
f1021d4e10
commit
41a05edcd4
@ -3,9 +3,9 @@ Qualification
|
||||
shorthand (CI Text)
|
||||
name (CI Text)
|
||||
description StoredMarkup Maybe -- user-defined large Html, ought to contain full description
|
||||
validDuration Word Maybe -- qualification is valid for this number of months or indefinitely
|
||||
validDuration Word Maybe -- qualification is valid indefinitely or for a specified time period
|
||||
auditDuration Word Maybe -- number of month to keep audit log
|
||||
refreshWithin CalendarDiffDays Maybe -- automatically schedule e-refresher within this number of month/days before expiry
|
||||
refreshWithin CalendarDiffDays Maybe -- notify users about renewal within this number of month/days before expiry
|
||||
elearningStart Bool -- automatically schedule e-refresher
|
||||
-- elearningOnly Bool -- successful E-learing automatically increases validity. NO!
|
||||
-- refreshInvitation StoredMarkup -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO!
|
||||
@ -71,7 +71,7 @@ QualificationUser
|
||||
--
|
||||
-- 4. REST POST Ergebnisse.csv: just save as is to LmsResult
|
||||
--
|
||||
-- 5. Daily Job LmsUserlist: -- Note: containment needs at-once processing
|
||||
-- 5. When received: Job LmsUserlist: -- Note: containment needs at-once processing
|
||||
-- - For all LmsUser:
|
||||
-- + if contained:
|
||||
-- set LmsUserReceived to Just now()
|
||||
@ -79,11 +79,14 @@ QualificationUser
|
||||
-- + not contianed, by LmsUserReceived is set: set LmsUserEnded to Just now()
|
||||
-- - move row to LmsAudit
|
||||
--
|
||||
-- 6. Daily Job LmsResult:
|
||||
-- 6. When received: Daily Job LmsResult:
|
||||
-- - set LmsUserReceived to Just now()
|
||||
-- - set LmsUserStatus to Just Day -- always
|
||||
-- - move row to LmsAudit
|
||||
|
||||
--
|
||||
-- 7. Daily Job: dequeue LMS Users
|
||||
-- -
|
||||
-- - remove from LmsUser after audit Period has passed
|
||||
|
||||
LmsUser
|
||||
qualification QualificationId OnDeleteCascade OnUpdateCascade
|
||||
|
||||
@ -28,8 +28,8 @@ dispatchJobLmsQualifications = JobHandlerAtomic act
|
||||
act = do
|
||||
qids <- E.select $ do
|
||||
q <- E.from $ E.table @Qualification
|
||||
E.where_ $ q E.^. QualificationElearningStart
|
||||
E.&&. E.isJust (q E.^. QualificationRefreshWithin)
|
||||
E.where_ $ E.isJust (q E.^. QualificationRefreshWithin)
|
||||
-- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless
|
||||
pure $ q E.^. QualificationId
|
||||
forM_ qids $ \(E.unValue -> qid) -> do
|
||||
$logInfoS "lms" $ "Start e-learning for qualification " <> tshow qid <> "."
|
||||
@ -58,8 +58,19 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
|
||||
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
||||
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
||||
)
|
||||
pure (quser E.^. QualificationUserUser)
|
||||
forM_ renewalUsers (\uid -> queueDBJob JobLmsEnqueueUser { jQualification = qid, jUser = E.unValue uid } )
|
||||
pure quser
|
||||
let usr_job :: Entity QualificationUser -> Job
|
||||
usr_job quser =
|
||||
let uid = quser ^. _entityVal . _qualificationUserUser
|
||||
_uex = quser ^. _entityVal . _qualificationUserValidUntil
|
||||
in if qualificationElearningStart quali
|
||||
then JobLmsEnqueueUser { jQualification = qid, jUser = uid }
|
||||
else error "TODO: send Notfification"
|
||||
{-
|
||||
JobSendNotification { jRecipientEmail = uid, jNotification =
|
||||
NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
|
||||
} -}
|
||||
forM_ renewalUsers (queueDBJob . usr_job)
|
||||
|
||||
|
||||
dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
|
||||
@ -84,8 +95,10 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
|
||||
case inserted of
|
||||
Nothing -> $logErrorS "LMS" "Generating and inserting fresh LmsIdent failed!"
|
||||
(Just _) -> error "continue here by notifying user by email or mail"
|
||||
|
||||
(Just _) -> error "TODO: send notification"
|
||||
{- queueDBJob JobSendNotification { jRecipientEmail = uid, jNotification =
|
||||
NotificationQualificationRenewal { nQualification = qid }
|
||||
} -}
|
||||
|
||||
dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
|
||||
dispatchJobLmsDequeue _qid =
|
||||
@ -100,30 +113,6 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
-- 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 $
|
||||
@ -136,12 +125,13 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
|
||||
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
|
||||
newStatus = lmsResultSuccess lresult & LmsSuccess
|
||||
oldStatus = lmsUserStatus luser
|
||||
-- always log success, since this is only transmitted once
|
||||
update luid [ LmsUserStatus =. Just lstatus
|
||||
update luid [ LmsUserStatus =. (oldStatus <> Just newStatus)
|
||||
, LmsUserReceived =. Just lreceived
|
||||
]
|
||||
insert_ $ LmsAudit qid (lmsUserIdent luser) lstatus lreceived now
|
||||
insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lreceived now
|
||||
delete lrid
|
||||
$logInfoS "LmsResult" [st|Processed ${tshow (length results)} LMS results|]
|
||||
|
||||
@ -168,14 +158,13 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
| 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
|
||||
let lReceived = lmsUserlistTimestamp lulist
|
||||
isBlocked = lmsUserlistFailed lulist
|
||||
newStatus = LmsBlocked $ utctDay lReceived
|
||||
oldStatus = lmsUserStatus luser
|
||||
update luid [ LmsUserStatus =. (oldStatus <> toMaybe isBlocked newStatus)
|
||||
, LmsUserReceived =. Just lReceived ]
|
||||
when isBlocked . insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lReceived now -- always log blocked
|
||||
delete lulid
|
||||
|
||||
$logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]
|
||||
|
||||
@ -20,6 +20,7 @@ import Jobs.Handler.SendNotification.Allocation
|
||||
import Jobs.Handler.SendNotification.ExamOffice
|
||||
import Jobs.Handler.SendNotification.CourseRegistered
|
||||
import Jobs.Handler.SendNotification.SubmissionEdited
|
||||
-- import Jobs.Handler.SendNotification.Qualification -- TODO
|
||||
|
||||
|
||||
dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX
|
||||
|
||||
@ -141,6 +141,8 @@ data Notification
|
||||
| NotificationSubmissionEdited { nInitiator :: UserId, nSubmission :: SubmissionId }
|
||||
| NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId }
|
||||
| NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId }
|
||||
-- | NotificationQualificationExpiry { nQualification :: QualificationId, nExpiry :: Day }
|
||||
-- | NotificationQualificationRenewal { nQualification :: QualificationId }
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
|
||||
instance Hashable Job
|
||||
|
||||
@ -32,6 +32,14 @@ data LmsStatus = LmsBlocked { lmsStatusDay :: Day }
|
||||
| LmsSuccess { lmsStatusDay :: Day }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData)
|
||||
|
||||
-- Variante 1: Der spätere Zeitstempel gewinnt, bei gleichem Zeitstempel gewinnt LmsSuccess? TODO: Macht das Sinn?!
|
||||
-- Variante 2: LmsSuccess gewinnt immer über LmsBlocked oder umgekehrt?
|
||||
instance Semigroup LmsStatus where
|
||||
a <> b | lmsStatusDay a > lmsStatusDay b = a -- nur Variante 1
|
||||
| lmsStatusDay a < lmsStatusDay b = b -- nur Variante 1
|
||||
| a >= b = a -- Variante 1 & 2, berücksichtigt Ord
|
||||
| otherwise = b
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ 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
|
||||
|
||||
@ -114,6 +114,7 @@ makeClassyFor_ ''StudyTerms
|
||||
makeClassyFor_ ''StudySubTerms
|
||||
|
||||
makeClassyFor_ ''Qualification
|
||||
makeClassyFor_ ''QualificationUser
|
||||
makeClassyFor_ ''LmsUser
|
||||
makeClassyFor_ ''LmsUserlist
|
||||
makeClassyFor_ ''LmsResult
|
||||
|
||||
Loading…
Reference in New Issue
Block a user