From f467f6086e627eb870e6323f9c0ec476a7c00ba3 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 a0433f6f3..2eaf8e481 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 @@ -139,6 +140,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 070339e14..9981b1c62 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