diff --git a/src/Handler/News.hs b/src/Handler/News.hs index 8df9d37c5..304c33fb3 100644 --- a/src/Handler/News.hs +++ b/src/Handler/News.hs @@ -7,7 +7,7 @@ import Handler.Utils.News import Handler.SystemMessage -import Utils.Schedule +import Utils.Schedule.Week import qualified Data.Map as Map import Database.Esqueleto.Utils.TH diff --git a/src/Utils/Schedule.hs b/src/Utils/Schedule.hs index 7c21ef789..ef642b980 100644 --- a/src/Utils/Schedule.hs +++ b/src/Utils/Schedule.hs @@ -1,5 +1,55 @@ module Utils.Schedule - ( module Utils.Schedule + ( fetchActiveTerms, fetchCourseEvents, fetchTutorials, fetchExamOccurrences ) where -import Utils.Schedule.Week as Utils.Schedule +import Import + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import Utils.Course +import Utils.Tutorial + +import Utils.Schedule.Types + + +fetchActiveTerms :: MonadHandler m => ReaderT SqlBackend m [E.Value TermId] +fetchActiveTerms = E.select $ E.from $ \term -> do + E.where_ $ term E.^. TermActive + return $ term E.^. TermId + +fetchCourseEvents :: MonadHandler m => Maybe UserId -> AuthTagActive -> UTCTime -> ReaderT SqlBackend m [ScheduleCourseEventInfo] +fetchCourseEvents muid ata now = E.select $ E.from $ \(course `E.InnerJoin` courseEvent) -> do + E.on $ course E.^. CourseId E.==. courseEvent E.^. CourseEventCourse + E.where_ $ mayViewCourse muid ata now course Nothing -- should not be necessary, but let's be on the safe side + E.&&. ( isCourseParticipant muid ata (course E.^. CourseId) + E.||. isCourseLecturer muid ata (course E.^. CourseId) + ) + return (course, courseEvent) + +fetchTutorials :: MonadHandler m => Maybe UserId -> AuthTagActive -> UTCTime -> ReaderT SqlBackend m [ScheduleTutorialInfo] +fetchTutorials muid ata now = E.select $ E.from $ \(course `E.InnerJoin` tutorial) -> do + E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse + E.where_ $ mayViewCourse muid ata now course Nothing -- should not be necessary, but let's be on the safe side + E.&&. ( isTutorialTutor muid ata (tutorial E.^. TutorialId) + E.||. isTutorialParticipant muid ata (tutorial E.^. TutorialId) + ) + return (course, tutorial) + +fetchExamOccurrences :: MonadHandler m => Maybe UserId -> AuthTagActive -> UTCTime -> ReaderT SqlBackend m [ScheduleExamOccurrenceInfo] +fetchExamOccurrences muid ata now = E.select $ E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examOccurrence) -> do + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.on $ exam E.^. ExamId E.==. examOccurrence E.^. ExamOccurrenceExam + E.where_ $ isCourseLecturer muid ata (course E.^. CourseId) + E.||. ( mayViewCourse muid ata now course Nothing -- do NOT remove, this is actually necessary here! + -- (There can be exam participants that are + -- not enrolled, me thinks) + E.&&. E.maybe E.false (\visibleFrom -> visibleFrom E.<=. E.val now) (exam E.^. ExamVisibleFrom) -- is the exam visible? + E.&&. E.maybe E.false (\publishOcc -> publishOcc E.<=. E.val now) (exam E.^. ExamPublishOccurrenceAssignments) -- are the exam occurrence assignments visible? + E.&&. (E.exists $ E.from $ \examRegistration -> E.where_ $ + examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId + E.&&. E.just (examRegistration E.^. ExamRegistrationUser) E.==. E.val muid + E.&&. E.maybe E.true (\registrationOccurrence -> registrationOccurrence E.==. examOccurrence E.^. ExamOccurrenceId) (examRegistration E.^. ExamRegistrationOccurrence) -- if registered for a specific occurrence, get only this one, otherwise get every occurrence available + ) + ) + return (course, exam, examOccurrence) diff --git a/src/Utils/Schedule/Types.hs b/src/Utils/Schedule/Types.hs index 200444771..a8a3c549c 100644 --- a/src/Utils/Schedule/Types.hs +++ b/src/Utils/Schedule/Types.hs @@ -1,10 +1,16 @@ module Utils.Schedule.Types - ( ScheduleEntry(..) + ( ScheduleCourseEventInfo, ScheduleTutorialInfo, ScheduleExamOccurrenceInfo + , ScheduleEntry(..) ) where import Import +type ScheduleCourseEventInfo = (Entity Course, Entity CourseEvent) +type ScheduleTutorialInfo = (Entity Course, Entity Tutorial) +type ScheduleExamOccurrenceInfo = (Entity Course, Entity Exam, Entity ExamOccurrence) + + data ScheduleEntry = ScheduleCourseEvent { sceCourse :: Entity Course -- TODO: just course? , sceType :: CourseEventType diff --git a/src/Utils/Schedule/Week.hs b/src/Utils/Schedule/Week.hs index cd3e68cb2..0ac761659 100644 --- a/src/Utils/Schedule/Week.hs +++ b/src/Utils/Schedule/Week.hs @@ -10,13 +10,10 @@ import qualified Data.Map as Map import qualified Data.Set as Set import qualified Database.Esqueleto as E -import qualified Database.Esqueleto.Utils as E import Handler.Utils.DateTime (formatTimeRangeW, formatTimeW) -import Utils.Course (mayViewCourse, isCourseLecturer, isCourseParticipant) -import Utils.Tutorial (isTutorialTutor, isTutorialParticipant) - +import Utils.Schedule import Utils.Schedule.Types import Utils.Schedule.Week.TimeSlot @@ -31,44 +28,13 @@ weekSchedule uid dayOffset = do -- TODO: single runDB for all fetches below? - activeTerms <- liftHandler . runDB $ E.select $ E.from $ \term -> do - E.where_ $ term E.^. TermActive - return $ term E.^. TermId + activeTerms <- liftHandler $ runDB fetchActiveTerms -- TODO: fetch course events for this week only? - courseEvents <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` courseEvent) -> do - E.on $ course E.^. CourseId E.==. courseEvent E.^. CourseEventCourse - E.where_ $ mayViewCourse (Just uid) ata now course Nothing -- should not be necessary, but let's be on the safe side - E.&&. ( isCourseParticipant (Just uid) ata (course E.^. CourseId) - E.||. isCourseLecturer (Just uid) ata (course E.^. CourseId) - ) - return (course, courseEvent) - - tutorials <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` tutorial) -> do - E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ mayViewCourse (Just uid) ata now course Nothing -- should not be necessary, but let's be on the safe side - E.&&. ( isTutorialTutor (Just uid) ata (tutorial E.^. TutorialId) - E.||. isTutorialParticipant (Just uid) ata (tutorial E.^. TutorialId) - ) - return (course, tutorial) - + courseEvents <- liftHandler $ runDB $ fetchCourseEvents (Just uid) ata now + tutorials <- liftHandler $ runDB $ fetchTutorials (Just uid) ata now -- TODO: this makes the exam table partly redundant => maybe remove? - examOccurrences <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examOccurrence) -> do - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.on $ exam E.^. ExamId E.==. examOccurrence E.^. ExamOccurrenceExam - E.where_ $ isCourseLecturer (Just uid) ata (course E.^. CourseId) - E.||. ( mayViewCourse (Just uid) ata now course Nothing -- do NOT remove, this is actually necessary here! - -- (There can be exam participants that are - -- not enrolled, me thinks) - E.&&. E.maybe E.false (\visibleFrom -> visibleFrom E.<=. E.val now) (exam E.^. ExamVisibleFrom) -- is the exam visible? - E.&&. E.maybe E.false (\publishOcc -> publishOcc E.<=. E.val now) (exam E.^. ExamPublishOccurrenceAssignments) -- are the exam occurrence assignments visible? - E.&&. (E.exists $ E.from $ \examRegistration -> E.where_ $ - examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId - E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid - E.&&. E.maybe E.true (\registrationOccurrence -> registrationOccurrence E.==. examOccurrence E.^. ExamOccurrenceId) (examRegistration E.^. ExamRegistrationOccurrence) -- if registered for a specific occurrence, get only this one, otherwise get every occurrence available - ) - ) - return (course, exam, examOccurrence) + examOccurrences <- liftHandler . runDB $ fetchExamOccurrences (Just uid) ata now let courseEventToScheduleEntries :: (Entity Course, Entity CourseEvent) -> [ScheduleEntry]