diff --git a/models/lms.model b/models/lms.model index 4b2e36ed6..f71b041ed 100644 --- a/models/lms.model +++ b/models/lms.model @@ -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 diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 864af0e04..735346302 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -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|] diff --git a/src/Jobs/Handler/SendNotification.hs b/src/Jobs/Handler/SendNotification.hs index 15e6f23d5..323cff640 100644 --- a/src/Jobs/Handler/SendNotification.hs +++ b/src/Jobs/Handler/SendNotification.hs @@ -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 diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index af12666b4..d2aaf422b 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -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 diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index bec3aeaf2..c3362c921 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index c5c105837..d8d137ccb 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -114,6 +114,7 @@ makeClassyFor_ ''StudyTerms makeClassyFor_ ''StudySubTerms makeClassyFor_ ''Qualification +makeClassyFor_ ''QualificationUser makeClassyFor_ ''LmsUser makeClassyFor_ ''LmsUserlist makeClassyFor_ ''LmsResult