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): rename schedule-related fetch functions, export should-be-displayed

Browse Source
This commit is contained in:
Sarah Vaupel 2020-11-10 20:28:08 +01:00
parent 3589831541
commit 45a5766210
2 changed files with 24 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
src/Utils/Schedule.hs
View File

@ -1,5 +1,6 @@
module Utils.Schedule
( fetchActiveTerms, fetchCourseEvents, fetchTutorials, fetchExamOccurrences
( fetchActiveTerms, fetchCourseEventsScheduleInfo, fetchTutorialsScheduleInfo, fetchExamOccurrencesScheduleInfo
, courseEventShouldBeDisplayedInSchedule, tutorialShouldBeDisplayedInSchedule, examOccurrenceShouldBeDisplayedInSchedule
) where
import Import
@ -13,35 +14,36 @@ import Utils.Tutorial
import Utils.Schedule.Types
-- TODO: move to general utils or use general utils function if available
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
fetchCourseEventsScheduleInfo :: MonadHandler m => Maybe UserId -> AuthTagActive -> UTCTime -> ReaderT SqlBackend m [ScheduleCourseEventInfo]
fetchCourseEventsScheduleInfo muid ata now = E.select $ E.from $ \(course `E.InnerJoin` courseEvent) -> do
E.on $ course E.^. CourseId E.==. courseEvent E.^. CourseEventCourse
E.where_ $ courseEventShouldBeDisplayed muid ata course courseEvent
E.where_ $ courseEventShouldBeDisplayedInSchedule muid ata course courseEvent
E.&&. mayViewCourse muid ata now course Nothing -- should not be necessary, but let's be on the safe side
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
fetchTutorialsScheduleInfo :: MonadHandler m => Maybe UserId -> AuthTagActive -> UTCTime -> ReaderT SqlBackend m [ScheduleTutorialInfo]
fetchTutorialsScheduleInfo muid ata now = E.select $ E.from $ \(course `E.InnerJoin` tutorial) -> do
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
E.where_ $ tutorialShouldBeDisplayed muid ata course tutorial
E.where_ $ tutorialShouldBeDisplayedInSchedule muid ata course tutorial
E.&&. mayViewCourse muid ata now course Nothing -- should not be necessary, but let's be on the safe side
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
fetchExamOccurrencesScheduleInfo :: MonadHandler m => Maybe UserId -> AuthTagActive -> UTCTime -> ReaderT SqlBackend m [ScheduleExamOccurrenceInfo]
fetchExamOccurrencesScheduleInfo 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_ $ examOccurrenceShouldBeDisplayed muid ata now course exam examOccurrence
E.where_ $ examOccurrenceShouldBeDisplayedInSchedule muid ata now course exam examOccurrence
return (course, exam, examOccurrence)
courseEventShouldBeDisplayed :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (Entity CourseEvent) -> E.SqlExpr (E.Value Bool)
courseEventShouldBeDisplayed muid@(Just uid) ata course courseEvent = E.exists . E.from $ \user ->
courseEventShouldBeDisplayedInSchedule :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (Entity CourseEvent) -> E.SqlExpr (E.Value Bool)
courseEventShouldBeDisplayedInSchedule muid@(Just uid) ata course courseEvent = E.exists . E.from $ \user ->
let
mCourseEventOpt = E.subSelect . E.from $ \courseEventScheduleOpt -> do
E.where_ $ courseEventScheduleOpt E.^. CourseEventScheduleOptCourseEvent E.==. courseEvent E.^. CourseEventId
@ -59,10 +61,10 @@ courseEventShouldBeDisplayed muid@(Just uid) ata course courseEvent = E.exists .
mCourseOpt
)
mCourseEventOpt
courseEventShouldBeDisplayed _ _ _ _ = E.false
courseEventShouldBeDisplayedInSchedule _ _ _ _ = E.false
tutorialShouldBeDisplayed :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (Entity Tutorial) -> E.SqlExpr (E.Value Bool)
tutorialShouldBeDisplayed muid@(Just uid) ata course tutorial = E.exists . E.from $ \user ->
tutorialShouldBeDisplayedInSchedule :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (Entity Tutorial) -> E.SqlExpr (E.Value Bool)
tutorialShouldBeDisplayedInSchedule muid@(Just uid) ata course tutorial = E.exists . E.from $ \user ->
let
mTutorialOpt = E.subSelect . E.from $ \tutorialScheduleOpt -> do
E.where_ $ tutorialScheduleOpt E.^. TutorialScheduleOptTutorial E.==. tutorial E.^. TutorialId
@ -79,10 +81,10 @@ tutorialShouldBeDisplayed muid@(Just uid) ata course tutorial = E.exists . E.fro
)
)
mTutorialOpt
tutorialShouldBeDisplayed _ _ _ _ = E.false
tutorialShouldBeDisplayedInSchedule _ _ _ _ = E.false
examOccurrenceShouldBeDisplayed :: Maybe UserId -> AuthTagActive -> UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (Entity Exam) -> E.SqlExpr (Entity ExamOccurrence) -> E.SqlExpr (E.Value Bool)
examOccurrenceShouldBeDisplayed muid@(Just uid) ata now course exam examOcc = E.exists . E.from $ \user ->
examOccurrenceShouldBeDisplayedInSchedule :: Maybe UserId -> AuthTagActive -> UTCTime -> E.SqlExpr (Entity Course) -> E.SqlExpr (Entity Exam) -> E.SqlExpr (Entity ExamOccurrence) -> E.SqlExpr (E.Value Bool)
examOccurrenceShouldBeDisplayedInSchedule muid@(Just uid) ata now course exam examOcc = E.exists . E.from $ \user ->
let
mExamOccOpt = E.subSelect . E.from $ \examOccScheduleOpt -> do
E.where_ $ examOccScheduleOpt E.^. ExamOccurrenceScheduleOptExamOccurrence E.==. examOcc E.^. ExamOccurrenceId
@ -110,7 +112,7 @@ examOccurrenceShouldBeDisplayed muid@(Just uid) ata now course exam examOcc = E.
)
)
mExamOccOpt
examOccurrenceShouldBeDisplayed _ _ _ _ _ _ = E.false
examOccurrenceShouldBeDisplayedInSchedule _ _ _ _ _ _ = E.false
-- Local helper functions

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

@ -35,10 +35,10 @@ weekSchedule (Entity uid User{userScheduleWeekDays=ScheduleWeekDays userSchedule
activeTerms <- liftHandler $ runDB fetchActiveTerms
-- TODO: fetch course events for this week only?
courseEvents <- liftHandler $ runDB $ fetchCourseEvents (Just uid) ata now
tutorials <- liftHandler $ runDB $ fetchTutorials (Just uid) ata now
courseEvents <- liftHandler $ runDB $ fetchCourseEventsScheduleInfo (Just uid) ata now
tutorials <- liftHandler $ runDB $ fetchTutorialsScheduleInfo (Just uid) ata now
-- TODO: this makes the exam table partly redundant => maybe remove?
examOccurrences <- liftHandler . runDB $ fetchExamOccurrences (Just uid) ata now
examOccurrences <- liftHandler . runDB $ fetchExamOccurrencesScheduleInfo (Just uid) ata now
let
courseEventToScheduleEntries :: ScheduleCourseEventInfo -> [ScheduleEntry]