refactor(daily): move caching into own submodule
we need those methods in Handler.Tutorial.Users as well
This commit is contained in:
parent
f467f6086e
commit
cd84d0a932
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
152
src/Handler/Utils/Course/Cache.hs
Normal file
152
src/Handler/Utils/Course/Cache.hs
Normal file
@ -0,0 +1,152 @@
|
||||
-- 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 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)
|
||||
@ -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
|
||||
|
||||
@ -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 --
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user