|
|
|
|
@ -6,11 +6,11 @@ import Import
|
|
|
|
|
|
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
|
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 Handler.Utils.DateTime (formatTimeRangeW)
|
|
|
|
|
import Handler.Utils.DateTime (formatTimeRangeW, formatTimeW)
|
|
|
|
|
|
|
|
|
|
import Utils.Schedule.Types
|
|
|
|
|
import Utils.Course (mayViewCourse)
|
|
|
|
|
@ -30,18 +30,23 @@ slotToDisplayTime :: TimeSlot -> Widget
|
|
|
|
|
slotToDisplayTime t = formatTimeRangeW SelFormatTime (TimeOfDay t 0 0) $ Just $ TimeOfDay (t + slotStep) 0 0
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
weekSchedule :: UserId -> Widget
|
|
|
|
|
weekSchedule uid = do
|
|
|
|
|
-- TODO: implement weekOffset
|
|
|
|
|
weekSchedule :: UserId
|
|
|
|
|
-> Maybe Int -- weekOffset
|
|
|
|
|
-> Widget
|
|
|
|
|
weekSchedule uid _weekOffset = do
|
|
|
|
|
now <- liftIO getCurrentTime
|
|
|
|
|
ata <- getSessionActiveAuthTags
|
|
|
|
|
|
|
|
|
|
-- TODO: single runDB for every fetch below?
|
|
|
|
|
-- TODO: single runDB for all fetches below?
|
|
|
|
|
-- TODO: filter by activeTerm only for regular occurrences, i.e. not for exceptions
|
|
|
|
|
|
|
|
|
|
-- TODO: fetch course events for this week only:
|
|
|
|
|
-- - for regular occurrences: check for active semester
|
|
|
|
|
-- - also fetch exceptions
|
|
|
|
|
courseEvents' <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` courseEvent) -> do
|
|
|
|
|
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 $ \term -> E.where_ $
|
|
|
|
|
-- term E.^. TermId E.==. course E.^. CourseTerm
|
|
|
|
|
-- E.&&. term E.^. TermActive
|
|
|
|
|
E.where_ $ (E.exists $ E.from $ \courseParticipant -> E.where_ $
|
|
|
|
|
courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
|
|
|
|
E.&&. courseParticipant E.^. CourseParticipantUser E.==. E.val uid
|
|
|
|
|
@ -53,10 +58,12 @@ weekSchedule uid = do
|
|
|
|
|
)
|
|
|
|
|
return (course, courseEvent)
|
|
|
|
|
|
|
|
|
|
-- TODO: fetch registered tutorials
|
|
|
|
|
-- TODO: also fetch tutorials with user as tutor
|
|
|
|
|
-- TODO: include in schedule
|
|
|
|
|
_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 $ \term -> E.where_ $
|
|
|
|
|
-- term E.^. TermId E.==. course E.^. CourseTerm
|
|
|
|
|
-- E.&&. term E.^. TermActive
|
|
|
|
|
E.where_ $ (E.exists $ E.from $ \tutorialParticipant -> E.where_ $
|
|
|
|
|
tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
|
|
|
|
|
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid
|
|
|
|
|
@ -66,59 +73,92 @@ weekSchedule uid = do
|
|
|
|
|
)
|
|
|
|
|
return (course, tutorial)
|
|
|
|
|
|
|
|
|
|
-- TODO: fetch exam occurrences for exam participants and lecturers
|
|
|
|
|
let _exams = []
|
|
|
|
|
-- TODO: fetch exam occurrences for exam participants and lecturers?
|
|
|
|
|
|
|
|
|
|
let
|
|
|
|
|
courseEventToScheduleEntry :: (Entity Course, Entity CourseEvent) -> ScheduleEntry
|
|
|
|
|
courseEventToScheduleEntry (seCourse, Entity _ CourseEvent{..}) =
|
|
|
|
|
let seType = SETCourseEvent { setceType = courseEventType }
|
|
|
|
|
seRoom = Just courseEventRoom
|
|
|
|
|
seOccurrences = courseEventTime
|
|
|
|
|
in ScheduleEntry{..}
|
|
|
|
|
|
|
|
|
|
occursInSlot :: DayOfWeek -> TimeSlot -> ScheduleEntry -> Bool
|
|
|
|
|
occursInSlot day slot ScheduleEntry{seOccurrences=Occurrences{..}} =
|
|
|
|
|
isScheduledInSlot day slot occurrencesScheduled && not (exceptNotOccursInSlot day slot occurrencesExceptions)
|
|
|
|
|
|| exceptOccursInSlot day slot occurrencesExceptions
|
|
|
|
|
|
|
|
|
|
isScheduledInSlot :: DayOfWeek -> TimeSlot -> Set OccurrenceSchedule -> Bool
|
|
|
|
|
isScheduledInSlot _day _slot _schedules = False -- TODO
|
|
|
|
|
|
|
|
|
|
exceptOccursInSlot :: DayOfWeek -> TimeSlot -> Set OccurrenceException -> Bool
|
|
|
|
|
exceptOccursInSlot _day _slot _exceptions = False -- TODO
|
|
|
|
|
courseEventToScheduleEntries :: (Entity Course, Entity CourseEvent) -> [ScheduleEntry]
|
|
|
|
|
courseEventToScheduleEntries (seCourse, Entity _ CourseEvent{courseEventType,courseEventRoom,courseEventTime=Occurrences{..}}) =
|
|
|
|
|
let seType = SETCourseEvent { setceType = courseEventType }
|
|
|
|
|
seRoom = Just courseEventRoom
|
|
|
|
|
scheduleds = Set.toList occurrencesScheduled <&> \scheduled ->
|
|
|
|
|
let seOccurrence = Right scheduled in ScheduleEntry{..}
|
|
|
|
|
exceptions = Set.toList occurrencesExceptions <&> \exception ->
|
|
|
|
|
let seOccurrence = Left exception in ScheduleEntry{..}
|
|
|
|
|
in scheduleds <> exceptions
|
|
|
|
|
|
|
|
|
|
exceptNotOccursInSlot :: DayOfWeek -> TimeSlot -> Set OccurrenceException -> Bool
|
|
|
|
|
exceptNotOccursInSlot _day _slot _exceptions = False -- TODO
|
|
|
|
|
|
|
|
|
|
-- TODO: remove
|
|
|
|
|
--formatTimeRangeOccurrencesInSlotW :: Occurrences -> TimeSlot -> Widget
|
|
|
|
|
--formatTimeRangeOccurrencesInSlotW Occurrences{..} slot =
|
|
|
|
|
-- let (start,mEnd) |
|
|
|
|
|
-- in formatTimeRangeW SelFormatTime start mEnd
|
|
|
|
|
seOccurrenceIsInSlot :: Day -> TimeSlot -> ScheduleEntryOccurrence -> Bool
|
|
|
|
|
seOccurrenceIsInSlot day slot seOcc =
|
|
|
|
|
let
|
|
|
|
|
(day', start, _mEnd) = case seOcc of
|
|
|
|
|
Right ScheduleWeekly{..} -> (scheduleDayOfWeek `dayOfWeekToDayWith` now, scheduleStart, Just scheduleEnd)
|
|
|
|
|
Left ExceptOccur{..} -> (exceptDay, exceptStart, Just exceptEnd)
|
|
|
|
|
Left ExceptNoOccur{exceptTime=LocalTime{..}} -> (localDay, localTimeOfDay, Nothing)
|
|
|
|
|
in day == day' && TimeOfDay slot 0 0 <= start && start < TimeOfDay (slot+slotStep) 0 0
|
|
|
|
|
|
|
|
|
|
-- TODO: use NonEmpty ScheduleEntry instead of [ScheduleEntry]
|
|
|
|
|
courseEvents :: Map DayOfWeek (Map TimeSlot [ScheduleEntry])
|
|
|
|
|
courseEvents = Map.fromList $ [Monday .. Sunday] <&> \day ->
|
|
|
|
|
courseEvents' :: Map Day (Map TimeSlot [ScheduleEntry])
|
|
|
|
|
courseEvents' = Map.fromList $ currentWeek <&> \day ->
|
|
|
|
|
( day
|
|
|
|
|
, Map.fromList $ slotsToDisplay <&> \slot ->
|
|
|
|
|
( slot
|
|
|
|
|
, flip filter (courseEventToScheduleEntry <$> courseEvents') $ occursInSlot day slot
|
|
|
|
|
-- \ScheduleEntry{seOccurrences} -> occursInSlot day slot seOccurrences
|
|
|
|
|
--seDayOfWeek == day && TimeOfDay slot 0 0 <= seStart && seStart < TimeOfDay (slot + slotStep) 0 0
|
|
|
|
|
, filter (seOccurrenceIsInSlot day slot . seOccurrence) $ join $ courseEventToScheduleEntries <$> courseEvents''
|
|
|
|
|
)
|
|
|
|
|
)
|
|
|
|
|
|
|
|
|
|
courseEvents :: Map Day (Map TimeSlot [ScheduleEntry])
|
|
|
|
|
courseEvents = courseEvents' <&> \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 ScheduleWeekly{..}} ->
|
|
|
|
|
-- TODO: is equality on scheduleStart sane?
|
|
|
|
|
not $ Left (ExceptNoOccur $ LocalTime (scheduleDayOfWeek `dayOfWeekToDayWith` now) scheduleStart)
|
|
|
|
|
`elem` (seOccurrence <$> occurrencesInSlot)
|
|
|
|
|
-- remove NoOccur exceptions if there is no regular occurrence to override
|
|
|
|
|
ScheduleEntry{seOccurrence=Left ExceptNoOccur{exceptTime=LocalTime{..}}} ->
|
|
|
|
|
any (\case
|
|
|
|
|
-- TODO: is equality on scheduleStart sane?
|
|
|
|
|
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
|
|
|
|
|
|
|
|
|
|
currentWeek :: [Day]
|
|
|
|
|
currentWeek = currentWeekAux $ utctDay now
|
|
|
|
|
where currentWeekAux day
|
|
|
|
|
| Monday <- dayOfWeek day = [day .. toEnum (fromEnum day + 6)]
|
|
|
|
|
| otherwise = currentWeekAux $ pred day
|
|
|
|
|
|
|
|
|
|
-- TODO: Internationalize week start (and/or make configurable)
|
|
|
|
|
-- TODO: auto-hide saturday and sunday (if there are no events scheduled)?
|
|
|
|
|
weekDays :: [(DayOfWeek,UniWorXMessage,Text)]
|
|
|
|
|
weekDays = [ (Monday , MsgScheduleWeekDayMonday , "mon")
|
|
|
|
|
, (Tuesday , MsgScheduleWeekDayTuesday , "tue")
|
|
|
|
|
, (Wednesday , MsgScheduleWeekDayWednesday , "wed")
|
|
|
|
|
, (Thursday , MsgScheduleWeekDayThursday , "thu")
|
|
|
|
|
, (Friday , MsgScheduleWeekDayFriday , "fri")
|
|
|
|
|
, (Saturday , MsgScheduleWeekDaySaturday , "sat")
|
|
|
|
|
, (Sunday , MsgScheduleWeekDaySunday , "sun")
|
|
|
|
|
weekDays :: [(Day, UniWorXMessage, Text)]
|
|
|
|
|
weekDays = zipWith (\x (y,z) -> (x,y,z)) currentWeek
|
|
|
|
|
[ (MsgScheduleWeekDayMonday , "mon")
|
|
|
|
|
, (MsgScheduleWeekDayTuesday , "tue")
|
|
|
|
|
, (MsgScheduleWeekDayWednesday , "wed")
|
|
|
|
|
, (MsgScheduleWeekDayThursday , "thu")
|
|
|
|
|
, (MsgScheduleWeekDayFriday , "fri")
|
|
|
|
|
, (MsgScheduleWeekDaySaturday , "sat")
|
|
|
|
|
, (MsgScheduleWeekDaySunday , "sun")
|
|
|
|
|
]
|
|
|
|
|
|
|
|
|
|
formatOccurrenceW :: Either OccurrenceException OccurrenceSchedule -> Widget
|
|
|
|
|
formatOccurrenceW = \case
|
|
|
|
|
Right ScheduleWeekly{..} -> [whamlet| _{MsgScheduleTime}: |] <> formatTimeRangeW SelFormatTime scheduleStart (Just scheduleEnd)
|
|
|
|
|
Left ExceptOccur{..} -> [whamlet| _{MsgScheduleOccur}: |] <> formatTimeRangeW SelFormatDateTime (LocalTime exceptDay exceptStart) (Just (LocalTime exceptDay exceptEnd))
|
|
|
|
|
Left ExceptNoOccur{exceptTime} -> [whamlet| _{MsgScheduleNoOccur}: |] <> formatTimeW SelFormatDateTime exceptTime
|
|
|
|
|
|
|
|
|
|
$(widgetFile "widgets/schedule/week")
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
-- Helper functions for this module
|
|
|
|
|
|
|
|
|
|
-- | 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
|
|
|
|
|
|
Sarah Vaupel