refactor(schedule): move event queries
This commit is contained in:
Sarah Vaupel
parent
ed40b89bfe
commit
d8227dcf8d
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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]
|
||||
|
||||
Reference in New Issue
Block a user