chore(lms): lmsstatus to proper semigroup, notifications for qualifications added but need more work
This commit is contained in:
Steffen Jost
parent
d4c4a60e7c
commit
39f16b90db
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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]
|
||||
|
||||
@ -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)) ()
|
||||
|
||||
@ -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|]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 --
|
||||
------------
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user