diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index c92b235e4..377fc616e 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -135,7 +135,7 @@ CourseUserTutorialsDeregistered count@Int64: Teilnehmer:in von #{show count} #{p CourseUserNoTutorialsDeregistered: Teilnehmer:in ist zu keinem der gewählten Kurse angemeldet CourseUserTutorials: Angemeldete Kurse CourseUserExams: Angemeldete Prüfungen -CourseUserExamOccurrences: Termine/Räume +CourseUserExamOccurrences: Prüfungstermin CourseUserSheets: Übungsblätter CsvColumnUserName: Voller Name des/der Teilnehmers/Teilnehmerin CsvColumnUserMatriculation: AVS Nummer des/der Teilnehmers/Teilnehmerin diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index 47123b096..a699a7256 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -135,7 +135,7 @@ CourseUserTutorialsDeregistered count: Sucessfully deregistered participant from CourseUserNoTutorialsDeregistered: Participant is not registered for any of the selected courses CourseUserTutorials: Registered courses CourseUserExams: Registered exams -CourseUserExamOccurrences: Occurrences/rooms +CourseUserExamOccurrences: Exam occurrence CourseUserSheets: Exercise sheets CsvColumnUserName: Participant's full name CsvColumnUserMatriculation: Participant's AVS number diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 6e3aac1da..375fbec59 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -10,7 +10,7 @@ module Handler.Course.Users , postCUsersR, getCUsersR , colUserSex' , colUserQualifications, colUserQualificationBlocked - , colUserExamOccurrences + , colUserExams, colUserExamOccurrences , _userQualifications ) where @@ -170,7 +170,7 @@ colUserExams tid ssh csh = sortable (Just "exams") (i18nCell MsgCourseUserExams) (examName . entityVal) colUserExamOccurrences :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) -colUserExamOccurrences _tid _ssh _csh = sortable (Just "exams") (i18nCell MsgCourseUserExamOccurrences) +colUserExamOccurrences _tid _ssh _csh = sortable (Just "exam-occurrences") (i18nCell MsgCourseUserExamOccurrences) $ \(view _userExamOccurrences -> exams') -> let exams = sortOn (examOccurrenceName . entityVal) exams' in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) $ listCell exams @@ -477,6 +477,15 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId return . E.min_ $ exam E.^. ExamName ) + , single ("exam-occurrences", SortColumn $ queryUser >>> \user -> + E.subSelectMaybe . E.from $ \(exam `E.InnerJoin` examRegistration `E.InnerJoin` examOccurrence) -> do + E.on $ examOccurrence E.^. ExamOccurrenceId E.=?. examRegistration E.^. ExamRegistrationOccurrence + E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam + E.&&. exam E.^. ExamCourse E.==. E.val cid + E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId + E.&&. E.isJust (examRegistration E.^. ExamRegistrationOccurrence) + return $ E.arrayAggWith E.AggModeDistinct (examOccurrence E.^. ExamOccurrenceName) [E.asc $ examOccurrence E.^. ExamOccurrenceName] + ) , single ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName)) , single ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState)) , mconcat diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 2eaf8e481..4286897e0 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -17,10 +17,10 @@ import Handler.Utils import Handler.Utils.Company -- import Handler.Utils.Occurrences import Handler.Utils.Avs +import Handler.Utils.Course.Cache -import qualified Data.Set as Set -import qualified Data.Map as Map -import qualified Data.Aeson as Aeson +import qualified Data.Set as Set +import qualified Data.Map as Map import qualified Data.Text as Text -- import Database.Persist.Sql (updateWhereCount) @@ -49,119 +49,6 @@ maxSuggestions = 7 -- data DailyTableActionData = DailyActDummyData -- deriving (Eq, Ord, Read, Show, Generic) --- | 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 DailyCacheKeys - = 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 - 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 - 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 - --- Datatype to be used for memcaching occurrences -data LessonCacheKey = LessonCacheKeyTutorials SchoolId (Day,Day) - deriving (Eq, Ord, Read, Show, Generic) - deriving anyclass (Hashable, Binary) - - --- | like getDayTutorials, but also returns the lessons occurring within the given time frame -getDayTutorials' :: SchoolId -> (Day,Day) -> DB (Map TutorialId [LessonTime]) -getDayTutorials' ssh dlimit@(dstart, dend ) - | dstart > dend = return mempty - | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (LessonCacheKeyTutorials 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 [LessonTime] - checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}) - | let lessons = Set.filter lessonFltr $ occurringLessons trm occ - , notNull lessons - = Map.singleton tutId $ 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 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/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index b7dbad725..56db6f364 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -14,6 +14,7 @@ import Utils.Form import Utils.Print import Handler.Utils import Handler.Utils.Course +-- import Handler.Utils.Course.Cache import Handler.Utils.Tutorial import Database.Persist.Sql (deleteWhereCount) @@ -61,8 +62,10 @@ getTUsersR = postTUsersR postTUsersR tid ssh csh tutn = do isAdmin <- hasReadAccessTo AdminR (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn + trm <- get404 tid + -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + -- tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn + (cid, tutEnt@(Entity tutid _)) <- fetchCourseIdTutorial tid ssh csh tutn qualifications <- getCourseQualifications cid now <- liftIO getCurrentTime let nowaday = utctDay now @@ -76,6 +79,7 @@ postTUsersR tid ssh csh tutn = do , pure $ colUserQualifications nowaday , pure $ colUserQualificationBlocked isAdmin nowaday , pure $ colUserExamOccurrences tid ssh csh + , pure $ colUserExams tid ssh csh ] psValidator = def & defaultSortingByName @@ -88,15 +92,27 @@ postTUsersR tid ssh csh tutn = do csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"] qualOptions = qualificationsOptionList qualifications - -- pick earliest still open associated exam - _mbExam <- selectFirst + + lessons = occurringLessons trm $ tutEnt ^. _entityVal . _tutorialTime . _Wrapped' -- TODO: export and show on page, since it is already computed! + _timespan = lessonTimesSpan lessons + + -- for purposes of table actions, pick all currently open associated exams + _exams <- selectList (-- ([ExamRegisterTo >=. Just now] ||. [ExamRegisterTo ==. Nothing]) ++ -- Reconsider: only allow exams with open registration? ([ExamEnd >=. Just now] ||. [ExamEnd ==. Nothing]) ++ [ ExamStart <=. Just now -- , ExamRegisterFrom <=. Just now , ExamCourse ==. cid, ExamClosed ==. Nothing, ExamFinished ==. Nothing -- Reconsider: ExamFinished prevents publication of results - do we want this? - ]) [Asc ExamRegisterFrom, Asc ExamStart, Asc ExamRegisterTo, Asc ExamName] -- earliest still open exam + ]) [Asc ExamRegisterFrom, Asc ExamStart, Asc ExamRegisterTo, Asc ExamName, LimitTo 7] -- earliest still open exam + -- tutorialTime -- pick exam occurrences and tutors -- TODO: !!!continue here!!! + -- _examOccs <- forM timespan $ \(dstart,dend) -> E.select $ do + -- occ <- E.from $ E.table @ExamOccurrence + -- E.where_ $ (occ E.^. ExamOccurrenceId `E.in_` E.valList (entityKey <$> exams)) + -- E.&&. ( E.day (occ E.^. ExamOccurrenceStart) `E.between` (E.val dstart, E.val dend) + -- E.||. E.dayMaybe (occ E.^. ExamOccurrenceEnd) `E.between` (E.justVal dstart, E.justVal dend) + -- ) + -- E.orderBy [E.asc $ occ E.^. ExamOccurrenceName] -- multiActionAOpts or similar, see FirmAction for another example let diff --git a/src/Handler/Utils/Course/Cache.hs b/src/Handler/Utils/Course/Cache.hs new file mode 100644 index 000000000..aae1b1bc6 --- /dev/null +++ b/src/Handler/Utils/Course/Cache.hs @@ -0,0 +1,152 @@ +-- 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 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) + +-- | retrieve all exam occurrences for a school in a given time period, ignoring term times; uses caching +getDayExamOccurrences :: SchoolId -> Maybe CourseId -> (Day,Day) -> DB (Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence)) +getDayExamOccurrences ssh mbcid dlimit@(dstart, dend ) + | dstart > dend = return mempty + | otherwise = memcachedByClass MemcachedKeyClassExamOccurrences (Just . Right $ 12 * diffDay) (CacheKeyExamOccurrences ssh dlimit mbcid) $ do + 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_ $ ifNothing mbcid id (\cid -> ((crs E.^. CourseId E.==. E.val cid) E.&&.)) $ + E.val ssh E.==. crs E.^. CourseSchool + E.&&. ( E.day (occ E.^. ExamOccurrenceStart) `E.between` (E.val dstart, E.val dend) + E.||. E.dayMaybe (occ E.^. ExamOccurrenceEnd) `E.between` (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) diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index 9981b1c62..f0067fd0b 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/src/Handler/Utils/Memcached.hs @@ -345,7 +345,7 @@ memcachedBy :: forall a m k. => Maybe Expiry -> k -> m a -> m a memcachedBy mExp k = memcachedWith (memcachedByGet k, \x -> x <$ memcachedBySet mExp k x) - +-- | Assign memcached keys to classes, which may be invalidated at once data MemcachedKeyClass = MemcachedKeyClassTutorialOccurrences | MemcachedKeyClassExamOccurrences diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index 9190f6abf..1c34d1ceb 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -5,6 +5,7 @@ module Handler.Utils.Occurrences ( LessonTime(..) , lessonTimeWidget, lessonTimesWidget + , lessonTimesSpan , occurringLessons , occurrencesWidget , occurrencesCompute, occurrencesCompute' @@ -76,6 +77,14 @@ lessonTimesWidget roomHidden lessonsSet = do let lessons = lessonTimeWidget roomHidden <$> lessonsSet $(widgetFile "widgets/lesson/set") +lessonTimesSpan :: Set LessonTime -> Maybe (Day, Day) +lessonTimesSpan ls = comb (Set.lookupMin lDays, Set.lookupMax lDays) + where + lDays = Set.foldr accDay mempty ls + accDay LessonTime{..} = Set.insert (localDay lessonStart) . Set.insert (localDay lessonEnd) + comb (Just x, Just y) = Just (x,y) + comb _ = Nothing + ----------------- -- Occurrences -- diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 1e3cd7d6b..ad92004b4 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1226,8 +1226,8 @@ fillDb = do insert_ $ TutorialParticipantDay tut2 svaupel nowaday True $ Just "Was on time" insert_ $ TutorialParticipantDay tut2 fhamann nowaday False $ Just "Missing" - when (odd tyear) $ - void . insert' $ Exam + when (tyear == currentYear) $ do + e <- insert' $ Exam { examCourse = c , examName = mkName "Theorieprüfung" , examGradingRule = Nothing @@ -1240,7 +1240,7 @@ fillDb = do , examRegisterTo = jtt TermDayLectureStart 14 Nothing toMidnight , examDeregisterUntil = jtt TermDayLectureStart 21 Nothing toMidnight , examStart = jtt TermDayLectureStart 27 Nothing $ toTimeOfDay 16 0 0 - , examEnd = jtt TermDayLectureStart 27 Nothing $ toTimeOfDay 16 30 0 + , examEnd = jtt TermDayLectureStart 32 Nothing $ toTimeOfDay 16 30 0 , examFinished = Nothing , examPartsFrom = Nothing , examClosed = Nothing @@ -1256,6 +1256,10 @@ fillDb = do , examStaff = Just "Jost" , examAuthorshipStatement = Nothing } + eOccA <- insert' $ ExamOccurrence e "OccA" (Just jost) (Just $ RoomReferenceSimple "Room A") False (Just 3) (termTime tid TermDayLectureStart 27 Nothing $ toTimeOfDay 16 0 0) (jtt TermDayLectureStart 27 Nothing $ toTimeOfDay 16 30 0) Nothing + eOccB <- insert' $ ExamOccurrence e "OccB" (Just gkleen) (Just $ RoomReferenceSimple "Room B") False (Just 4) (termTime tid TermDayLectureStart 28 Nothing $ toTimeOfDay 16 5 0) (jtt TermDayLectureStart 28 Nothing $ toTimeOfDay 16 35 0) Nothing + insert_ $ ExamRegistration e svaupel (Just eOccA) now + insert_ $ ExamRegistration e fhamann (Just eOccB) now insert_ $ UserDay svaupel nowaday True insert_ $ UserDay fhamann nowaday False