188 lines
11 KiB
Haskell
188 lines
11 KiB
Haskell
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- 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
|
|
}
|
|
)) |