fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

refactor(schedule): move event queries

Browse Source
This commit is contained in:
Sarah Vaupel 2020-08-24 16:04:37 +02:00
parent ed40b89bfe
commit d8227dcf8d
4 changed files with 65 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Handler/News.hs
View File

@ -7,7 +7,7 @@ import Handler.Utils.News
import Handler.SystemMessage import Handler.SystemMessage
import Utils.Schedule import Utils.Schedule.Week
import qualified Data.Map as Map import qualified Data.Map as Map
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH

54
src/Utils/Schedule.hs
View File

@ -1,5 +1,55 @@
module Utils.Schedule module Utils.Schedule
( module Utils.Schedule ( fetchActiveTerms, fetchCourseEvents, fetchTutorials, fetchExamOccurrences
) where ) 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)

8
src/Utils/Schedule/Types.hs
View File

@ -1,10 +1,16 @@
module Utils.Schedule.Types module Utils.Schedule.Types
( ScheduleEntry(..) ( ScheduleCourseEventInfo, ScheduleTutorialInfo, ScheduleExamOccurrenceInfo
, ScheduleEntry(..)
) where ) where
import Import 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 data ScheduleEntry = ScheduleCourseEvent
{ sceCourse :: Entity Course -- TODO: just course? { sceCourse :: Entity Course -- TODO: just course?
, sceType :: CourseEventType , sceType :: CourseEventType

44
src/Utils/Schedule/Week.hs
View File

@ -10,13 +10,10 @@ import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import Handler.Utils.DateTime (formatTimeRangeW, formatTimeW) import Handler.Utils.DateTime (formatTimeRangeW, formatTimeW)
import Utils.Course (mayViewCourse, isCourseLecturer, isCourseParticipant) import Utils.Schedule
import Utils.Tutorial (isTutorialTutor, isTutorialParticipant)
import Utils.Schedule.Types import Utils.Schedule.Types
import Utils.Schedule.Week.TimeSlot import Utils.Schedule.Week.TimeSlot
@ -31,44 +28,13 @@ weekSchedule uid dayOffset = do
-- TODO: single runDB for all fetches below? -- TODO: single runDB for all fetches below?
activeTerms <- liftHandler . runDB $ E.select $ E.from $ \term -> do activeTerms <- liftHandler $ runDB fetchActiveTerms
E.where_ $ term E.^. TermActive
return $ term E.^. TermId
-- TODO: fetch course events for this week only? -- TODO: fetch course events for this week only?
courseEvents <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` courseEvent) -> do courseEvents <- liftHandler $ runDB $ fetchCourseEvents (Just uid) ata now
E.on $ course E.^. CourseId E.==. courseEvent E.^. CourseEventCourse tutorials <- liftHandler $ runDB $ fetchTutorials (Just uid) ata now
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)
-- TODO: this makes the exam table partly redundant => maybe remove? -- 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 examOccurrences <- liftHandler . runDB $ fetchExamOccurrences (Just uid) ata now
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)
let let
courseEventToScheduleEntries :: (Entity Course, Entity CourseEvent) -> [ScheduleEntry] courseEventToScheduleEntries :: (Entity Course, Entity CourseEvent) -> [ScheduleEntry]