201 lines
11 KiB
Haskell
201 lines
11 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
|
|
|
|
|
|
-- TODO: implement dayOffset
|
|
weekSchedule :: UserId -> Maybe Integer -> Widget
|
|
weekSchedule uid _dayOffset = do
|
|
now <- liftIO getCurrentTime
|
|
tz <- liftIO getCurrentTimeZone
|
|
ata <- getSessionActiveAuthTags
|
|
|
|
-- 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 redundant once the weekOffset is implemented
|
|
-- TODO: for lecturers, do not display one entry for each exam occurrences, but instead collect all occurrences happening at the same time in a list
|
|
examOccurrences <- liftHandler . runDB $ E.select $ E.from $ \((course `E.InnerJoin` exam) `E.LeftOuterJoin` examOccurrence) -> do
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.on $ E.just (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.just (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 (seCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType,courseEventRoom,courseEventTime=Occurrences{..}}) =
|
|
let seType = SETCourseEvent { setceType = courseEventType }
|
|
seRoom = Just courseEventRoom
|
|
scheduleds
|
|
-- omit regular occurrences if the course's term is not currently active
|
|
| not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty
|
|
| otherwise = Set.toList occurrencesScheduled <&> \scheduled ->
|
|
let seOccurrence = Right (Right scheduled) in ScheduleEntry{..}
|
|
exceptions = Set.toList occurrencesExceptions <&> \exception ->
|
|
let seOccurrence = Right (Left exception) in ScheduleEntry{..}
|
|
in scheduleds <> exceptions
|
|
|
|
tutorialToScheduleEntries :: (Entity Course, Entity Tutorial) -> [ScheduleEntry]
|
|
tutorialToScheduleEntries (seCourse@(Entity _ Course{..}), Entity _ Tutorial{tutorialType,tutorialName,tutorialRoom,tutorialTime=Occurrences{..}}) =
|
|
let seType = SETTutorial { settType = tutorialType, settName = tutorialName }
|
|
seRoom = tutorialRoom
|
|
scheduleds
|
|
-- omit regular occurrences if the course's term is not currently active
|
|
| not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty
|
|
| otherwise = Set.toList occurrencesScheduled <&> \scheduled ->
|
|
let seOccurrence = Right (Right scheduled) in ScheduleEntry{..}
|
|
exceptions = Set.toList occurrencesExceptions <&> \exception ->
|
|
let seOccurrence = Right (Left exception) in ScheduleEntry{..}
|
|
in scheduleds <> exceptions
|
|
|
|
examOccurrenceToScheduleEntry :: (Entity Course, Entity Exam, Maybe (Entity ExamOccurrence)) -> Maybe ScheduleEntry
|
|
examOccurrenceToScheduleEntry (seCourse@(Entity _ Course{}), Entity _ Exam{..}, Just (Entity _ ExamOccurrence{..})) =
|
|
let seType = SETExamOccurrence
|
|
{ seteoExamName = examName
|
|
}
|
|
seRoom = Just examOccurrenceRoom
|
|
seOccurrence = Left $ ScheduleEntryExamOccurrence
|
|
{ seeoStart = examOccurrenceStart
|
|
, seeoEnd = examOccurrenceEnd
|
|
}
|
|
in Just ScheduleEntry{..}
|
|
examOccurrenceToScheduleEntry _ = Nothing -- TODO: exclude (_,_,Nothing) case via join
|
|
|
|
seOccurrenceIsInSlot :: Day -> TimeSlot -> ScheduleEntryOccurrence -> Bool
|
|
seOccurrenceIsInSlot day slot = \case
|
|
Right occurrence -> occStart `isInTimeSlot` (day, slot) where
|
|
occStart = case occurrence of
|
|
Right ScheduleWeekly{..} -> (scheduleDayOfWeek `dayOfWeekToDayWith` now, scheduleStart)
|
|
Left ExceptOccur{..} -> (exceptDay, exceptStart)
|
|
Left ExceptNoOccur{exceptTime=LocalTime{..}} -> (localDay, localTimeOfDay)
|
|
Left ScheduleEntryExamOccurrence{..} -> let slotUTCTime = timeSlotToUTCTime tz day slot
|
|
nextSlotUTCTime = timeSlotToUTCTime tz day (slot+slotStep)
|
|
in slotUTCTime <= seeoStart
|
|
&& seeoStart < nextSlotUTCTime
|
|
|
|
events' :: Map Day (Map Int [ScheduleEntry])
|
|
events' = Map.fromList $ week <&> \day ->
|
|
( day
|
|
, Map.fromList $ slotsToDisplay <&> \slot ->
|
|
( slot
|
|
, filter (seOccurrenceIsInSlot day slot . seOccurrence) $ join $
|
|
(courseEventToScheduleEntries <$> courseEvents)
|
|
<> (tutorialToScheduleEntries <$> tutorials)
|
|
<> (pure . catMaybes) (examOccurrenceToScheduleEntry <$> examOccurrences)
|
|
)
|
|
)
|
|
|
|
events :: Map Day (Map Int [ScheduleEntry])
|
|
events = events' <&> \slotsPerDay -> slotsPerDay <&> \occurrencesInSlot ->
|
|
let
|
|
isRegularWithoutException :: ScheduleEntry -> Bool
|
|
isRegularWithoutException = \case
|
|
-- remove regular occurrences if there is a NoOccur exception for the occurrence of this week
|
|
ScheduleEntry{seOccurrence=Right (Right ScheduleWeekly{..})} ->
|
|
-- TODO: is equality on scheduleStart sane?
|
|
not $ Right (Left $ ExceptNoOccur $ LocalTime (scheduleDayOfWeek `dayOfWeekToDayWith` now) scheduleStart)
|
|
`elem` (seOccurrence <$> occurrencesInSlot)
|
|
-- remove NoOccur exceptions if there is no regular occurrence to override
|
|
ScheduleEntry{seOccurrence=Right (Left ExceptNoOccur{exceptTime=LocalTime{..}})} ->
|
|
any (\case
|
|
-- TODO: is equality on scheduleStart sane?
|
|
Right (Right ScheduleWeekly{..}) -> scheduleDayOfWeek `dayOfWeekToDayWith` now == localDay
|
|
&& scheduleStart == localTimeOfDay
|
|
_ -> False
|
|
) (seOccurrence <$> occurrencesInSlot)
|
|
_ -> True -- TODO: maybe filter out ExceptNoOccurs? (Should NoOccurs be displayed or not?)
|
|
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 $ utctDay now
|
|
where go day
|
|
| Monday <- dayOfWeek day = [day .. toEnum (fromEnum day + 6)]
|
|
| otherwise = go $ pred day
|
|
|
|
$(widgetFile "widgets/schedule/week")
|
|
|
|
|
|
-- Local helper functions
|
|
|
|
-- | To which route should each schedule entry link to?
|
|
scheduleEntryToHref :: ScheduleEntry -> Route UniWorX
|
|
scheduleEntryToHref ScheduleEntry{seCourse=Entity _ Course{..},seType} = case seType of
|
|
SETCourseEvent{} -> CourseR courseTerm courseSchool courseShorthand CShowR -- TODO: link to events table? (TODO currently has no id)
|
|
SETTutorial{} -> CourseR courseTerm courseSchool courseShorthand CShowR -- TODO: link to table with id "tutorials"?
|
|
SETExamOccurrence{..} -> CExamR courseTerm courseSchool courseShorthand seteoExamName EShowR
|
|
|
|
-- | Calls formatTimeRangeW with the correct arguments and prepends an occurrence descriptor based on the occurrence type
|
|
formatOccurrenceW :: ScheduleEntryOccurrence -> Widget
|
|
formatOccurrenceW = \case
|
|
Right (Right ScheduleWeekly{..}) -> [whamlet| _{MsgScheduleTime}: |] <> formatTimeRangeW SelFormatTime scheduleStart (Just scheduleEnd)
|
|
Right (Left ExceptOccur{..}) -> [whamlet| _{MsgScheduleOccur}: |] <> formatTimeRangeW SelFormatTime (LocalTime exceptDay exceptStart) (Just $ LocalTime exceptDay exceptEnd)
|
|
Right (Left ExceptNoOccur{}) -> [whamlet| _{MsgScheduleNoOccur} |] -- <> formatTimeW SelFormatDateTime exceptTime
|
|
Left ScheduleEntryExamOccurrence{..} -> [whamlet| _{MsgScheduleOccur}: |] <> formatTimeRangeW SelFormatTime seeoStart seeoEnd
|
|
|
|
-- | 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 time (as UTCTime)
|
|
dayOfWeekToDayWith :: DayOfWeek -> UTCTime -> Day
|
|
dayOfWeekToDayWith weekDay = go . utctDay where
|
|
go day | weekDay' == weekDay = day
|
|
| weekDay' > weekDay = go $ pred day
|
|
| otherwise = go $ succ day
|
|
where weekDay' = dayOfWeek day
|