chore(lms): lmsstatus to proper semigroup, notifications for qualifications added but need more work

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"

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
 

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
 

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]

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

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"
+                    else JobSendNotification { jRecipient = uid, jNotification = 
-                          {-
-                          JobSendNotification { jRecipientEmail = 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"
+        (Just _) -> queueDBJob JobSendNotification { jRecipient = uid, jNotification = 
-                    {- queueDBJob JobSendNotification { jRecipientEmail = 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)
+        if saneDate 
-                    , LmsUserReceived =. Just lreceived 
+          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|]

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

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

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 :: QualificationId -> UserId -> Handler ()
-dispatchNotificationQualificationRenewal _nQualification _nExpiry _jRecipient = 
+dispatchNotificationQualificationRenewal _nQualification _jRecipient = 
   error "dispatchNotificationQualificationRenewal not yet implemented TODO"
   -- userMailT jRecipient $ do

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 }
+  | NotificationQualificationExpiry  { nQualification :: QualificationId, nExpiry :: Day }
-  -- | NotificationQualificationRenewal { nQualification :: QualificationId }
+  | NotificationQualificationRenewal { nQualification :: QualificationId }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 
 instance Hashable Job

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?!
+isLmsSuccess :: LmsStatus -> Bool 
--- Variante 2: LmsSuccess gewinnt immer über LmsBlocked oder umgekehrt?
+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
+  a <> b | a >= b    = a  
-         | lmsStatusDay a < lmsStatusDay b = b -- nur Variante 1
-         | a >= b    = a  -- Variante 1 & 2, berücksichtigt Ord
          | otherwise = b
 
 deriveJSON  defaultOptions

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)
 

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

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

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