-- SPDX-FileCopyrightText: 2024 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Utils.Course.Cache where import Import import Handler.Utils -- import Handler.Utils.Occurrences import Handler.Exam.Form (ExamOccurrenceForm(..)) import qualified Data.Set as Set import qualified Data.Map as Map -- import qualified Data.Aeson as Aeson -- import Database.Persist.Sql (updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E -- import Database.Esqueleto.PostgreSQL.JSON ((@>.)) -- import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.)) -- partial JSON object to be used for filtering with "@>" -- ensure that a GIN index for the jsonb column is created in Model.Migration.Definitions -- occurrenceDayValue :: Day -> Value -- occurrenceDayValue d = Aeson.object -- [ "exceptions" Aeson..= -- [ Aeson.object -- [ "exception" Aeson..= ("occur"::Text) -- , "day" Aeson..= d -- ] ] ] {- More efficient DB-only version, but ignores regular schedules getDayTutorials :: SchoolId -> Day -> DB [TutorialId] getDayTutorials ssh d = E.unValue <<$>> E.select (do (trm :& crs :& tut) <- 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 @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse) E.where_ $ E.between (E.val d) (trm E.^. TermStart, trm E.^. TermEnd) E.&&. crs E.^. CourseSchool E.==. E.val ssh E.&&. (E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue d)) return $ tut E.^. TutorialId ) -} -- | Datatype to be used as key for memcaching DayTask related stuff; note that newtype-CacheKeys are optimized away, so multiple constructors are advisable data CourseCacheKeys = CacheKeyTutorialOccurrences SchoolId (Day,Day) -- ^ Map TutorialId (TutorialName, [LessonTime]) | CacheKeyExamOccurrences SchoolId (Day,Day) (Maybe CourseId) -- ^ Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence) | CacheKeySuggsParticipantNote SchoolId TutorialId | CacheKeySuggsAttendanceNote SchoolId TutorialId | CacheKeyTutorialCheckResults SchoolId Day deriving (Eq, Ord, Read, Show, Generic) deriving anyclass (Hashable, Binary, NFData) -- getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId] -- getDayTutorials ssh dlimit@(dstart, dend ) -- | dstart > dend = return mempty -- | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (CacheKeyTutorialOccurrences ssh dlimit) $ do -- same key is ok, distinguished by return type -- candidates <- E.select $ do -- (trm :& crs :& tut) <- 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 @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse) -- E.where_ $ crs E.^. CourseSchool E.==. E.val ssh -- E.&&. trm E.^. TermStart E.<=. E.val dend -- E.&&. trm E.^. TermEnd E.>=. E.val dstart -- return (trm, tut, E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue dstart)) -- -- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates -- return $ mapMaybe checkCandidate candidates -- where -- period = Set.fromAscList [dstart..dend] -- checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- most common case -- checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}, _) -- | not $ Set.null $ Set.intersection period $ occurrencesCompute' trm occ -- = Just tutId -- | otherwise -- = Nothing -- | like the previous version above, but also returns the lessons occurring within the given time frame -- Due to caching, we only use the more informative version, unless experiments with the full DB show otherwise getDayTutorials :: SchoolId -> (Day,Day) -> DB (Map TutorialId (TutorialName, [LessonTime])) getDayTutorials ssh dlimit@(dstart, dend ) | dstart > dend = return mempty | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (CacheKeyTutorialOccurrences ssh dlimit) $ do candidates <- E.select $ do (trm :& crs :& tut) <- 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 @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse) E.where_ $ crs E.^. CourseSchool E.==. E.val ssh E.&&. trm E.^. TermStart E.<=. E.val dend E.&&. trm E.^. TermEnd E.>=. E.val dstart return (trm, tut) -- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates return $ foldMap checkCandidate candidates where checkCandidate :: (Entity Term, Entity Tutorial) -> Map TutorialId (TutorialName, [LessonTime]) checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ, tutorialName=tName}}) | let lessons = Set.filter lessonFltr $ occurringLessons trm occ , notNull lessons = Map.singleton tutId (tName , Set.toAscList lessons) -- due to Set not having a Functor instance, we need mostly need lists anyway | otherwise = mempty lessonFltr :: LessonTime -> Bool lessonFltr LessonTime{..} = dstart <= localDay lessonStart && dend >= localDay lessonEnd -- -- retrieve all exam occurrences for a school for a term 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 ExamOccurrenceMap = Map ExamOccurrenceId (ExamOccurrence, CryptoUUIDExamOccurrence, (ExamId, ExamName)) type ExamToOccurrencesMap = Map ExamId (Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm) -- | retrieve all exam occurrences for a school in a given time period, ignoring term times; uses caching -- if a CourseId is specified, only exams from that course are returned getDayExamOccurrences :: Bool -> SchoolId -> Maybe CourseId -> (Day,Day) -> DB ExamOccurrenceMap getDayExamOccurrences onlyOpen ssh mbcid dlimit@(dstart, dend) | dstart > dend = return mempty | otherwise = memcachedByClass MemcachedKeyClassExamOccurrences (Just . Right $ 12 * diffDay) (CacheKeyExamOccurrences ssh dlimit mbcid) $ do now <- liftIO getCurrentTime candidates <- E.select $ do (crs :& exm :& occ) <- E.from $ E.table @Course `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.and $ catMaybes [ toMaybe onlyOpen $ E.justVal now E.>=. exm E.^. ExamRegisterFrom -- fail on null E.&&. E.val now E.<~. exm E.^. ExamRegisterTo -- success on null , mbcid <&> ((E.==. (crs E.^. CourseId)) . E.val) , Just $ crs E.^. CourseSchool E.==. E.val ssh , Just $ E.withinPeriod dlimit (occ E.^. ExamOccurrenceStart) (occ E.^. ExamOccurrenceEnd) ] -- E.orderBy [E.asc $ exm E.^. ExamName] -- we return a map, so the order does not matter return (occ, exm E.^. ExamId, exm E.^. ExamName) -- No Binary instance for Entity Exam, so we only extract what is needed for now foldMapM mkOccMap candidates where mkOccMap :: (Entity ExamOccurrence, E.Value ExamId, E.Value ExamName) -> DB ExamOccurrenceMap mkOccMap (Entity{..}, E.Value eId, E.Value eName) = encrypt entityKey <&> (\ceoId -> Map.singleton entityKey (entityVal, ceoId, (eId, eName))) mkExamOccurrenceOptions :: ExamOccurrenceMap -> OptionList ExamOccurrenceId mkExamOccurrenceOptions = mkOptionListGrouped . map (over _2 $ sortBy (compare `on` optionDisplay)) . groupSort . map mkEOOption . Map.toList where mkEOOption :: (ExamOccurrenceId, (ExamOccurrence, CryptoUUIDExamOccurrence, (ExamId, ExamName))) -> (Text, [Option ExamOccurrenceId]) mkEOOption (eid, (ExamOccurrence{examOccurrenceName}, ceoId, (_,eName))) = (ciOriginal eName, [Option{..}]) where optionDisplay = ciOriginal examOccurrenceName optionExternalValue = toPathPiece ceoId optionInternalValue = eid convertExamOccurrenceMap :: ExamOccurrenceMap -> ExamToOccurrencesMap convertExamOccurrenceMap eom = Map.fromListWith (<>) $ map aux $ Map.toList eom where aux :: (ExamOccurrenceId, (ExamOccurrence, CryptoUUIDExamOccurrence, (ExamId, ExamName))) -> (ExamId, (Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm)) aux (_, (ExamOccurrence{..}, cueoId, (eid,_))) = (eid, (Set.singleton cueoId, Set.singleton ExamOccurrenceForm { eofId = Just cueoId , eofName = Just examOccurrenceName , eofExaminer = examOccurrenceExaminer , eofRoom = examOccurrenceRoom , eofRoomHidden = examOccurrenceRoomHidden , eofCapacity = examOccurrenceCapacity , eofStart = examOccurrenceStart , eofEnd = examOccurrenceEnd , eofDescription = examOccurrenceDescription } ))