From 92a43ac1313a0de32c6e7dabff75f38bd90b2204 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 13 Dec 2024 17:27:02 +0100 Subject: [PATCH] chore(daily): add function to retrieve all exam occurrences for given days the function uses the memcachedByClass mechanism, which was slightly refined as well to include the class within the memcached keys for added correctness --- models/exams.model | 2 +- src/Handler/Exam/Edit.hs | 1 + src/Handler/Exam/New.hs | 1 + src/Handler/School/DayTasks.hs | 25 ++++++++++++++++++++++++- src/Handler/Utils/Memcached.hs | 5 +++-- 5 files changed, 30 insertions(+), 4 deletions(-) diff --git a/models/exams.model b/models/exams.model index 89a812ad0..8dd6f3ad5 100644 --- a/models/exams.model +++ b/models/exams.model @@ -47,7 +47,7 @@ ExamOccurrence end UTCTime Maybe description StoredMarkup Maybe UniqueExamOccurrence exam name - deriving Generic + deriving Show Generic Binary ExamRegistration exam ExamId user UserId diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index 5178809ed..ed7d56100 100644 --- a/src/Handler/Exam/Edit.hs +++ b/src/Handler/Exam/Edit.hs @@ -152,6 +152,7 @@ postEEditR tid ssh csh examn = do deleteWhere [ ExamCorrectorExam ==. eId ] insertMany_ $ map (ExamCorrector eId) adds memcachedByInvalidate AuthCacheExamCorrectorList $ Proxy @(Set UserId) + memcachedInvalidateClass MemcachedKeyClassExamOccurrences deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ] sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index 9ba6cd12e..d3cc42690 100644 --- a/src/Handler/Exam/New.hs +++ b/src/Handler/Exam/New.hs @@ -93,6 +93,7 @@ postCExamNewR tid ssh csh = do ] sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites memcachedByInvalidate AuthCacheExamCorrectorList $ Proxy @(Set UserId) + memcachedInvalidateClass MemcachedKeyClassExamOccurrences let recordNoShow (Entity _ CourseParticipant{..}) = do didRecord <- is _Just <$> insertUnique ExamResult diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 68a2218d9..b19a3486d 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -74,7 +74,8 @@ getDayTutorials ssh d = E.unValue <<$>> E.select (do -- | Datatype to be used as key for memcaching DayTask related stuff; note that newtype-CacheKeys are optimized away, so multiple constructors are advisable data DailyCacheKeys - = CacheKeyTutorialOccurrences SchoolId (Day,Day) + = CacheKeyTutorialOccurrences SchoolId (Day,Day) -- ^ Map TutorialId (TutorialName, [LessonTime]) + | CacheKeyExamOccurrences SchoolId (Day,Day) -- ^ Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence) | CacheKeySuggsParticipantNote SchoolId TutorialId | CacheKeySuggsAttendanceNote SchoolId TutorialId | CacheKeyTutorialCheckResults SchoolId Day @@ -134,6 +135,28 @@ getDayTutorials ssh dlimit@(dstart, dend ) lessonFltr LessonTime{..} = dstart <= localDay lessonStart && dend >= localDay lessonEnd +-- | retrieve all exam occurrences for a school in a given time period; uses caching +getDayExamOccurrences :: SchoolId -> (Day,Day) -> DB (Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence)) +getDayExamOccurrences ssh dlimit@(dstart, dend ) + | dstart > dend = return mempty + | otherwise = memcachedByClass MemcachedKeyClassExamOccurrences (Just . Right $ 12 * diffDay) (CacheKeyExamOccurrences ssh dlimit) $ do + candidates <- E.select $ do + (trm :& crs :& exm :& occ) <- E.from $ E.table @Term + `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) + `E.innerJoin` E.table @Exam `E.on` (\(_ :& crs :& exm) -> crs E.^. CourseId E.==. exm E.^. ExamCourse) + `E.innerJoin` E.table @ExamOccurrence `E.on` (\(_ :& _ :& exm :& occ) -> exm E.^. ExamId E.==. occ E.^. ExamOccurrenceExam) + E.where_ $ E.val ssh E.==. crs E.^. CourseSchool + E.&&. E.val dstart E.<=. trm E.^. TermEnd + E.&&. E.val dend E.>=. trm E.^. TermStart + E.&&. ( E.between (E.day $ occ E.^. ExamOccurrenceStart) (E.val dstart, E.val dend) + E.||. E.between (E.dayMaybe $ occ E.^. ExamOccurrenceEnd) (E.justVal dstart, E.justVal dend) + ) + return (exm, occ) + return $ foldMap mkOccMap candidates + where + mkOccMap :: (Entity Exam, Entity ExamOccurrence) -> Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence) + mkOccMap (entityVal -> exm, Entity{..}) = Map.singleton entityKey (exm ^. _examCourse, exm ^. _examName, entityVal) + type DailyTableExpr = ( E.SqlExpr (Entity Course) diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index 9c47ca93f..c7dba703f 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/src/Handler/Utils/Memcached.hs @@ -364,10 +364,11 @@ memcachedByClass :: forall a m k. , Binary k ) => MemcachedKeyClass -> Maybe Expiry -> k -> m a -> m a -memcachedByClass mkc mExp k = memcachedWith (memcachedByGet k, setAndAddClass) +memcachedByClass mkc mExp k = memcachedWith (memcachedByGet ck, setAndAddClass) where + ck = (mkc, k) setAndAddClass v = do - mbKey <- memcachedBySet' mExp k v + mbKey <- memcachedBySet' mExp ck v whenIsJust mbKey $ \vKey -> do cl <- maybeMonoid <$> memcachedByGet mkc memcachedBySet Nothing mkc $ MemcachedKeyClassStore $ Set.insert vKey $ unMemcachedKeyClassStore cl