215 lines
12 KiB
Haskell
215 lines
12 KiB
Haskell
module Utils.Schedule.Week
|
|
( weekSchedule
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
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)
|
|
|
|
import Utils.Schedule.Types
|
|
import Utils.Schedule.Week.TimeSlot
|
|
|
|
|
|
weekSchedule :: UserId -> Maybe Integer -> Widget
|
|
weekSchedule uid dayOffset = do
|
|
now <- liftIO getCurrentTime
|
|
tz <- liftIO getCurrentTimeZone
|
|
ata <- getSessionActiveAuthTags
|
|
|
|
let dayNowOffset = fromMaybe 0 dayOffset `addDays` utctDay now
|
|
|
|
-- 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
|
|
|
|
-- 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_ $ (E.exists $ E.from $ \courseParticipant -> E.where_ $
|
|
courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
|
E.&&. courseParticipant E.^. CourseParticipantUser E.==. E.val uid
|
|
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
E.&&. mayViewCourse (Just uid) ata now course Nothing -- should not be necessary, but let's be on the safe side
|
|
) E.||. (E.exists $ E.from $ \lecturer -> E.where_ $
|
|
lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
|
E.&&. lecturer E.^. LecturerUser E.==. E.val uid
|
|
)
|
|
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_ $ (E.exists $ E.from $ \tutorialParticipant -> E.where_ $
|
|
tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
|
|
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid
|
|
E.&&. mayViewCourse (Just uid) ata now course Nothing -- should not be necessary, but let's be on the safe side
|
|
) E.||. (E.exists $ E.from $ \tutor -> E.where_ $
|
|
tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
|
E.&&. tutor E.^. TutorUser E.==. E.val uid
|
|
)
|
|
return (course, tutorial)
|
|
|
|
-- 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.||. (E.exists $ E.from $ \examRegistration -> E.where_ $
|
|
examRegistration E.^. ExamRegistrationUser E.==. E.val uid
|
|
E.&&. E.maybe E.false (\visibleFrom -> visibleFrom E.<=. E.val now) (exam E.^. ExamVisibleFrom)
|
|
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)
|
|
return (course, exam, examOccurrence)
|
|
|
|
let
|
|
courseEventToScheduleEntries :: (Entity Course, Entity CourseEvent) -> [ScheduleEntry]
|
|
courseEventToScheduleEntries (sceCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType=sceType,courseEventRoom=sceRoom,courseEventTime=Occurrences{..}}) =
|
|
let scheduleds
|
|
-- omit regular occurrences if the course term is not currently active
|
|
| not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty
|
|
| otherwise = Set.toList occurrencesScheduled <&> \scheduled ->
|
|
let sceOccurrence = Right scheduled in ScheduleCourseEvent{..}
|
|
exceptions = Set.toList occurrencesExceptions <&> \exception ->
|
|
let sceOccurrence = Left exception in ScheduleCourseEvent{..}
|
|
in scheduleds <> exceptions
|
|
|
|
tutorialToScheduleEntries :: (Entity Course, Entity Tutorial) -> [ScheduleEntry]
|
|
tutorialToScheduleEntries (stCourse@(Entity _ Course{..}), Entity _ Tutorial{tutorialName=stName,tutorialType=stType,tutorialRoom=stRoom,tutorialTime=Occurrences{..}}) =
|
|
let scheduleds
|
|
-- omit regular occurrences if the course term is not currently active
|
|
| not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty
|
|
| otherwise = Set.toList occurrencesScheduled <&> \scheduled ->
|
|
let stOccurrence = Right scheduled in ScheduleTutorial{..}
|
|
exceptions = Set.toList occurrencesExceptions <&> \exception ->
|
|
let stOccurrence = Left exception in ScheduleTutorial{..}
|
|
in scheduleds <> exceptions
|
|
|
|
-- TODO: introduce type synonym for (Entity Course, Entity Exam, Entity ExamOccurrence)?
|
|
joinParallelExamOccurrences :: [(Entity Course, Entity Exam, Entity ExamOccurrence)] -> [(Entity Course, Entity Exam, NonEmpty (Entity ExamOccurrence))]
|
|
joinParallelExamOccurrences = go [] where
|
|
go acc [] = acc
|
|
go acc (examOcc@(course, exam, occ):examOccs) =
|
|
let ((((view _3) <$>) -> parallel), other) = partition (examOcc `isParallelTo`) examOccs
|
|
in go ((course, exam, occ:|parallel):acc) other
|
|
(Entity cid _, Entity eid _, Entity _ occ) `isParallelTo` (Entity cid' _, Entity eid' _, Entity _ occ') =
|
|
cid == cid' && eid == eid'
|
|
&& examOccurrenceStart occ == examOccurrenceStart occ' && examOccurrenceEnd occ == examOccurrenceEnd occ'
|
|
|
|
examOccurrenceToScheduleEntry :: (Entity Course, Entity Exam, NonEmpty (Entity ExamOccurrence)) -> ScheduleEntry
|
|
examOccurrenceToScheduleEntry (seoCourse@(Entity _ Course{}), Entity _ Exam{examName=seoExamName}, examOccs@((Entity _ occ):|_)) =
|
|
let seoRooms = (examOccurrenceRoom . entityVal) <$> examOccs
|
|
seoStart = examOccurrenceStart occ -- multiple exam occurrences are joined on equality of start and end,
|
|
seoEnd = examOccurrenceEnd occ -- so taking the timestamps of the first occurrence suffices
|
|
in ScheduleExamOccurrence{..}
|
|
|
|
seIsInSlot :: Day -> TimeSlot -> ScheduleEntry -> Bool
|
|
seIsInSlot day slot =
|
|
let occurrenceIsInSlot occurrence = occDay == day && occTime `isInTimeSlot` slot where
|
|
(occDay, occTime) = case occurrence of
|
|
Right ScheduleWeekly{..} -> (scheduleDayOfWeek `dayOfWeekToDayWith` dayNowOffset, scheduleStart)
|
|
Left ExceptOccur{..} -> (exceptDay, exceptStart)
|
|
Left ExceptNoOccur{exceptTime=LocalTime{..}} -> (localDay, localTimeOfDay)
|
|
in \case
|
|
ScheduleCourseEvent{sceOccurrence} -> occurrenceIsInSlot sceOccurrence
|
|
ScheduleTutorial{stOccurrence} -> occurrenceIsInSlot stOccurrence
|
|
ScheduleExamOccurrence{seoStart} -> let slotTime = timeSlotToUTCTime tz day slot
|
|
nextSlotTime = timeSlotToUTCTime tz day (slot+slotStep)
|
|
in slotTime <= seoStart
|
|
&& seoStart < nextSlotTime
|
|
|
|
events' :: Map Day (Map TimeSlot [ScheduleEntry])
|
|
events' = Map.fromList $ week <&> \day ->
|
|
( day
|
|
, Map.fromList $ slotsToDisplay <&> \slot ->
|
|
( slot
|
|
, filter (seIsInSlot day slot) $ join $
|
|
(courseEventToScheduleEntries <$> courseEvents)
|
|
<> (tutorialToScheduleEntries <$> tutorials)
|
|
<> pure (examOccurrenceToScheduleEntry <$> (joinParallelExamOccurrences examOccurrences))
|
|
)
|
|
)
|
|
|
|
getRegulars :: [ScheduleEntry] -> [OccurrenceSchedule]
|
|
getRegulars = catMaybes . (goRegular <$>) where
|
|
goRegular ScheduleCourseEvent{sceOccurrence=Right schedule} = Just schedule
|
|
goRegular ScheduleTutorial{stOccurrence=Right schedule} = Just schedule
|
|
goRegular _ = Nothing
|
|
|
|
getNoOccurs :: [ScheduleEntry] -> [OccurrenceException]
|
|
getNoOccurs = catMaybes . (goNoOccur <$>) where
|
|
goNoOccur ScheduleCourseEvent{sceOccurrence=Left noOccur} = Just noOccur
|
|
goNoOccur ScheduleTutorial{stOccurrence=Left noOccur} = Just noOccur
|
|
goNoOccur _ = Nothing
|
|
|
|
events :: Map Day (Map TimeSlot [ScheduleEntry])
|
|
events = events' <&> \slotsPerDay -> slotsPerDay <&> \occurrencesInSlot ->
|
|
let
|
|
isRegularWithoutException :: ScheduleEntry -> Bool
|
|
isRegularWithoutException =
|
|
let -- remove regular occurrences if there is a NoOccur exception for the occurrence of this week
|
|
goPrune (Right ScheduleWeekly{..}) = not $ ExceptNoOccur (LocalTime (scheduleDayOfWeek `dayOfWeekToDayWith` dayNowOffset) scheduleStart) `elem` (getNoOccurs occurrencesInSlot)
|
|
-- remove NoOccur exceptions if there is no regular occurrence to override
|
|
goPrune (Left ExceptNoOccur{exceptTime=LocalTime{..}}) =
|
|
any (\ScheduleWeekly{..} -> scheduleDayOfWeek `dayOfWeekToDayWith` dayNowOffset == localDay
|
|
&& scheduleStart == localTimeOfDay
|
|
) (getRegulars occurrencesInSlot)
|
|
goPrune _ = True -- TODO: maybe filter NoOccur exceptions in general? (Should NoOccur exceptions be displayed?)
|
|
in \case
|
|
ScheduleCourseEvent{sceOccurrence} -> goPrune sceOccurrence
|
|
ScheduleTutorial{stOccurrence} -> goPrune stOccurrence
|
|
_ -> True
|
|
in filter isRegularWithoutException occurrencesInSlot
|
|
|
|
-- TODO: Internationalize default week start (and/or make configurable)
|
|
-- TODO: auto-hide saturday and sunday (if there are no events scheduled)?
|
|
week :: [Day]
|
|
week = go $ fromMaybe 0 dayOffset `addDays` utctDay now
|
|
where go day
|
|
| dayOfWeek day == firstDay = [day .. toEnum (fromEnum day + 6)]
|
|
| otherwise = go $ pred day
|
|
firstDay = toEnum $ fromEnum Monday + fromInteger (fromMaybe 0 dayOffset)
|
|
|
|
$(widgetFile "widgets/schedule/week")
|
|
|
|
|
|
-- Local helper functions
|
|
|
|
-- | To which route should each schedule entry link to?
|
|
scheduleEntryToHref :: ScheduleEntry -> Route UniWorX
|
|
scheduleEntryToHref = \case
|
|
ScheduleCourseEvent{sceCourse=(Entity _ Course{..})} -> CourseR courseTerm courseSchool courseShorthand CShowR -- TODO: link to events table? (currently has no id)
|
|
ScheduleTutorial{stCourse=(Entity _ Course{..})} -> CourseR courseTerm courseSchool courseShorthand CShowR -- TODO: link to table with id "tutorials"?
|
|
ScheduleExamOccurrence{seoCourse=(Entity _ Course{..}),seoExamName} -> CExamR courseTerm courseSchool courseShorthand seoExamName EShowR
|
|
|
|
-- | Calls formatTimeRangeW with the correct arguments and prepends an occurrence descriptor based on the occurrence type
|
|
formatEitherOccurrenceW :: Either OccurrenceException OccurrenceSchedule -> Widget
|
|
formatEitherOccurrenceW = \case
|
|
Right ScheduleWeekly{..} -> [whamlet| _{MsgScheduleTime}: |] <> formatTimeRangeW SelFormatTime scheduleStart (Just scheduleEnd)
|
|
Left ExceptOccur{..} -> [whamlet| _{MsgScheduleOccur}: |] <> formatTimeRangeW SelFormatTime (LocalTime exceptDay exceptStart) (Just $ LocalTime exceptDay exceptEnd)
|
|
Left ExceptNoOccur{} -> [whamlet| _{MsgScheduleNoOccur} |] -- <> formatTimeW SelFormatDateTime exceptTime
|
|
|
|
-- | Uniquely identify each day as table head
|
|
-- | This avoids constantly hiding e.g. some DayOfWeek (which would interfere with day offsets)
|
|
dayTableHeadIdent :: Day -> Text
|
|
dayTableHeadIdent = tshow . toModifiedJulianDay
|
|
|
|
-- | Convert from DayOfWeek to Day of this week using the current day
|
|
dayOfWeekToDayWith :: DayOfWeek -> Day -> Day
|
|
dayOfWeekToDayWith weekDay = go where
|
|
go day | weekDay' == weekDay = day
|
|
| weekDay' > weekDay = go $ pred day
|
|
| otherwise = go $ succ day
|
|
where weekDay' = dayOfWeek day
|