From 39f16b90dbdc5f3bfb554f17cc451f1af3c149ca Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 8 Apr 2022 17:28:55 +0200 Subject: [PATCH] chore(lms): lmsstatus to proper semigroup, notifications for qualifications added but need more work --- config/settings.yml | 2 ++ .../categories/settings/de-de-formal.msg | 1 + .../uniworx/categories/settings/en-eu.msg | 1 + src/Handler/Profile.hs | 1 + src/Jobs/Crontab.hs | 10 ++++++++ src/Jobs/Handler/LMS.hs | 25 +++++++++++-------- src/Jobs/Handler/QueueNotification.hs | 5 ++++ src/Jobs/Handler/SendNotification.hs | 2 +- .../Handler/SendNotification/Qualification.hs | 4 +-- src/Jobs/Types.hs | 4 +-- src/Model/Types/Lms.hs | 11 ++++---- src/Model/Types/Mail.hs | 1 + src/Settings.hs | 4 +++ src/Utils.hs | 4 +++ test/Model/TypesSpec.hs | 10 ++++++++ 15 files changed, 64 insertions(+), 21 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 9a82fbf96..7f51c53af 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -68,6 +68,8 @@ synchronise-ldap-users-interval: "_env:SYNCHRONISE_LDAP_INTERVAL:3600" study-features-recache-relevance-within: 172800 study-features-recache-relevance-interval: 293 +qualification-check: 28800 + log-settings: detailed: "_env:DETAILED_LOGGING:false" all: "_env:LOG_ALL:false" diff --git a/messages/uniworx/categories/settings/de-de-formal.msg b/messages/uniworx/categories/settings/de-de-formal.msg index 1c92b705e..08b5d2457 100644 --- a/messages/uniworx/categories/settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/de-de-formal.msg @@ -76,6 +76,7 @@ NotificationTriggerSubmissionEdited: Eine meiner Übungsblatt-Abgaben wurde ver NotificationTriggerSubmissionUserDeleted: Ich wurde als Mitabgebender von einer Übungsblatt-Abgabe entfernt NotificationTriggerAllocationNewCourse: Es wurde ein neuer Kurs eingetragen zu einer Zentralanmeldungen, zu der ich meine Teilnahme registriert habe NotificationTriggerAllocationNewCourseTip: Kann pro Zentralanmeldung überschrieben werden +NotificationTriggerQualification: Eine meiner Qualifikationen läuft ab UserDisplayNameRules: Vorgaben für den angezeigten Namen diff --git a/messages/uniworx/categories/settings/en-eu.msg b/messages/uniworx/categories/settings/en-eu.msg index fe8374754..697ecd60e 100644 --- a/messages/uniworx/categories/settings/en-eu.msg +++ b/messages/uniworx/categories/settings/en-eu.msg @@ -76,6 +76,7 @@ NotificationTriggerSubmissionEdited: One of my exercise sheet submissions was ch NotificationTriggerSubmissionUserDeleted: I was removed from one of my exercise sheet submissions NotificationTriggerAllocationNewCourse: A new course was added to a central allocation for which I have registered my participation NotificationTriggerAllocationNewCourseTip: Can be overridden per central allocation +NotificationTriggerQualification: My Qualifications are about to expire UserDisplayNameRules: Specification for display names diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 9b7dc1ee0..f8d8389f1 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -248,6 +248,7 @@ notificationForm template = wFormToAForm $ do NTExamOfficeExamResults -> Just $ NTKFunctionary SchoolExamOffice NTExamOfficeExamResultsChanged -> Just $ NTKFunctionary SchoolExamOffice NTCourseRegistered -> Just NTKAll + NTQualification -> Just NTKAll -- _other -> Nothing forcedTriggers = [NTUserRightsUpdate, NTUserAuthModeUpdate] diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 368daf8de..9214d50b6 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -360,6 +360,16 @@ determineCrontab = execWriterT $ do , cronRateLimit = appStudyFeaturesRecacheRelevanceInterval , cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appStudyFeaturesRecacheRelevanceInterval nextIntervalTime } +{- + whenIsJust appQualificationChecks $ \cInterval -> tell $ HashMap.singleton + (JobCtlQueue JobLmsQualifications) + Cron + { cronInitial = CronAsap + , cronRepeat = CronRepeatScheduled . CronCalendar $ cronCalendarAny {} + , cronRateLimit = TODO: CONTINUE HERE + , cronNotAfter = + } +-} let correctorNotifications :: Map (UserId, SheetId) (Max UTCTime) -> WriterT (Crontab JobCtl) (ReaderT SqlReadBackend (HandlerFor UniWorX)) () diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 735346302..351a70de4 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -62,14 +62,12 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act let usr_job :: Entity QualificationUser -> Job usr_job quser = let uid = quser ^. _entityVal . _qualificationUserUser - _uex = quser ^. _entityVal . _qualificationUserValidUntil + uex = quser ^. _entityVal . _qualificationUserValidUntil in if qualificationElearningStart quali then JobLmsEnqueueUser { jQualification = qid, jUser = uid } - else error "TODO: send Notfification" - {- - JobSendNotification { jRecipientEmail = uid, jNotification = + else JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } - } -} + } forM_ renewalUsers (queueDBJob . usr_job) @@ -95,10 +93,10 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser case inserted of Nothing -> $logErrorS "LMS" "Generating and inserting fresh LmsIdent failed!" - (Just _) -> error "TODO: send notification" - {- queueDBJob JobSendNotification { jRecipientEmail = uid, jNotification = + (Just _) -> queueDBJob JobSendNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid } - } -} + } + dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX dispatchJobLmsDequeue _qid = @@ -127,10 +125,15 @@ dispatchJobLmsResults qid = JobHandlerAtomic act let lreceived = lmsResultTimestamp lresult newStatus = lmsResultSuccess lresult & LmsSuccess oldStatus = lmsUserStatus luser + saneDate = lmsResultSuccess lresult `inBetween` (utctDay $ lmsUserStarted luser, utctDay now) -- always log success, since this is only transmitted once - update luid [ LmsUserStatus =. (oldStatus <> Just newStatus) - , LmsUserReceived =. Just lreceived - ] + if saneDate + then + update luid [ LmsUserStatus =. (oldStatus <> Just newStatus) + , LmsUserReceived =. Just lreceived + ] + else + $logErrorS "LmsResult" [st|LMS success with insane date ${tshow (lmsResultSuccess lresult)} received|] insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lreceived now delete lrid $logInfoS "LmsResult" [st|Processed ${tshow (length results)} LMS results|] diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index aa3247ccd..cd64cb89f 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -300,6 +300,9 @@ determineNotificationCandidates = awaitForever $ \notif -> do E.&&. application E.^. CourseApplicationCourse E.==. E.val nCourse return (hasOverride, user) + NotificationQualificationExpiry{} -> return mempty -- Not used with JobQueueNotification; recipients already known + NotificationQualificationRenewal{} -> return mempty -- Not used with JobQueueNotification; recipients already known + classifyNotification :: Notification -> DB NotificationTrigger @@ -335,3 +338,5 @@ classifyNotification NotificationSubmissionEdited{} = return NTSub classifyNotification NotificationSubmissionUserCreated{} = return NTSubmissionUserCreated classifyNotification NotificationSubmissionUserDeleted{} = return NTSubmissionUserDeleted classifyNotification NotificationAllocationNewCourse{} = return NTAllocationNewCourse +classifyNotification NotificationQualificationExpiry{} = return NTQualification +classifyNotification NotificationQualificationRenewal{} = return NTQualification diff --git a/src/Jobs/Handler/SendNotification.hs b/src/Jobs/Handler/SendNotification.hs index 323cff640..4b31fcafa 100644 --- a/src/Jobs/Handler/SendNotification.hs +++ b/src/Jobs/Handler/SendNotification.hs @@ -20,7 +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 +import Jobs.Handler.SendNotification.Qualification dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index dfdf25cf5..333b46478 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -43,7 +43,7 @@ dispatchNotificationQualificationExpiry _nQualification _nExpiry _jRecipient = addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationNewCourse.hamlet") -} -dispatchNotificationQualificationRenewal :: QualificationId -> Day -> UserId -> Handler () -dispatchNotificationQualificationRenewal _nQualification _nExpiry _jRecipient = +dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler () +dispatchNotificationQualificationRenewal _nQualification _jRecipient = error "dispatchNotificationQualificationRenewal not yet implemented TODO" -- userMailT jRecipient $ do \ No newline at end of file diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index d2aaf422b..0a275354e 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -141,8 +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 } + | 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 c3362c921..fc3317cbb 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -32,12 +32,13 @@ 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? +isLmsSuccess :: LmsStatus -> Bool +isLmsSuccess LmsSuccess{} = True +isLmsSuccess _other = False + +-- Entscheidung 08.04.22: 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 + a <> b | a >= b = a | otherwise = b deriveJSON defaultOptions diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs index e3b6cdd93..2c18315b6 100644 --- a/src/Model/Types/Mail.hs +++ b/src/Model/Types/Mail.hs @@ -63,6 +63,7 @@ data NotificationTrigger | NTExamOfficeExamResults | NTExamOfficeExamResultsChanged | NTCourseRegistered + | NTQualification deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving anyclass (Universe, Finite, Hashable, NFData) diff --git a/src/Settings.hs b/src/Settings.hs index 84d910a5a..b1cab0497 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -219,6 +219,8 @@ data AppSettings = AppSettings , appStudyFeaturesRecacheRelevanceWithin :: Maybe NominalDiffTime , appStudyFeaturesRecacheRelevanceInterval :: NominalDiffTime + , appQualificationCheck :: Maybe NominalDiffTime + , appFileSourceARCConf :: Maybe (ARCConf Int) , appFileSourcePrewarmConf :: Maybe PrewarmCacheConf @@ -681,6 +683,8 @@ instance FromJSON AppSettings where appStudyFeaturesRecacheRelevanceWithin <- o .:? "study-features-recache-relevance-within" appStudyFeaturesRecacheRelevanceInterval <- o .: "study-features-recache-relevance-interval" + appQualificationCheck <- o .:? "qualification-check" + appFileSourceARCConf <- assertM isValidARCConf <$> o .:? "file-source-arc" let isValidPrewarmConf PrewarmCacheConf{..} = and diff --git a/src/Utils.hs b/src/Utils.hs index db49a7af2..275e68602 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1524,6 +1524,10 @@ minOn,maxOn :: Ord b => (a -> b) -> a -> a -> a minOn = minBy . comparing maxOn = maxBy . comparing +inBetween:: Ord a => a -> (a,a) -> Bool +inBetween x (lower,upper) = lower <= x && x <= upper + + ------------ -- Random -- ------------ diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index c1a2e509f..22ee157b9 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -352,6 +352,8 @@ instance Arbitrary SchoolAuthorshipStatementMode where instance Arbitrary SheetAuthorshipStatementMode where arbitrary = genericArbitrary +instance Arbitrary LmsStatus where + arbitrary = genericArbitrary spec :: Spec spec = do @@ -460,6 +462,8 @@ spec = do [ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws, binaryLaws, httpApiDataLaws ] lawsCheckHspec (Proxy @SheetAuthorshipStatementMode) [ eqLaws, ordLaws, showLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws, binaryLaws, httpApiDataLaws ] + lawsCheckHspec (Proxy @LmsStatus) + [ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ @@ -564,6 +568,12 @@ spec = do showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 0, byDeficit = 0 } CorrectorNormal `shouldBe` "-D" showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 0 } CorrectorMissing `shouldBe` "[1.0 - D]" showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1, byDeficit = 0 } CorrectorExcused `shouldBe` "{1.0 - D}" + describe "Semigroup LmsStatus" $ do + it "LmsSuccess supersedes LmsBlocked" . property $ + \p1 p2 -> (isLmsSuccess p1 || isLmsSuccess p2) == isLmsSuccess (p1 <> p2) + it "lmsStatusDay merges to latest" . property $ + \p1 p2 -> (isLmsSuccess p1 == isLmsSuccess p2) ==> lmsStatusDay (p1 <> p2) == max (lmsStatusDay p1) (lmsStatusDay p2) + termExample :: (TermIdentifier, Text) -> Expectation termExample (term, encoded) = example $ do