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

fix(schedule-week): use UTCTime for exam occurrences

Browse Source
This commit is contained in:
Sarah Vaupel 2020-08-21 12:53:29 +02:00
parent 693b36e789
commit 9b869b0bb5
2 changed files with 29 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -33,8 +33,7 @@ type ScheduleEntryOccurrence = Either ScheduleEntryExamOccurrence (Either Occurr
-- Similar to OccurrenceException, but with Maybe as end
data ScheduleEntryExamOccurrence = ScheduleEntryExamOccurrence
{ seeoDay :: Day
, seeoStart :: TimeOfDay
, seeoEnd :: Maybe TimeOfDay
{ seeoStart :: UTCTime
, seeoEnd :: Maybe UTCTime
}
deriving (Eq, Ord, Show, Read, Generic, Typeable)

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

@ -34,6 +34,7 @@ slotToDisplayTime t = formatTimeRangeW SelFormatTime (TimeOfDay t 0 0) $ Just $
-- TODO: implement weekOffset
-- TODO: use more general dayOffset instead of weekOffset
weekSchedule :: UserId -> Maybe Int -> Widget
weekSchedule uid _weekOffset = do
now <- liftIO getCurrentTime
@ -113,28 +114,40 @@ weekSchedule uid _weekOffset = do
in scheduleds <> exceptions
examToScheduleEntries :: (Entity Course, Entity Exam, Maybe (Entity ExamOccurrence)) -> [ScheduleEntry]
examToScheduleEntries (_, _, Nothing) = mempty
examToScheduleEntries (seCourse@(Entity _ Course{}), Entity _ Exam{..}, Just (Entity _ ExamOccurrence{..})) =
let seType = SETExamOccurrence
{ seteoExamName = examName
{ seteoExamName = examName
}
seRoom = Just examOccurrenceRoom
seOccurrence = Left $ ScheduleEntryExamOccurrence
{ seeoDay = utctDay examOccurrenceStart
, seeoStart = timeToTimeOfDay $ utctDayTime examOccurrenceStart
, seeoEnd = (timeToTimeOfDay . utctDayTime) <$> examOccurrenceEnd
{ seeoStart = examOccurrenceStart
, seeoEnd = examOccurrenceEnd
}
in pure $ ScheduleEntry{..}
examToScheduleEntries _ = mempty -- TODO: exclude (_,_,Nothing) case via join
seOccurrenceIsInSlot :: Day -> TimeSlot -> ScheduleEntryOccurrence -> Bool
seOccurrenceIsInSlot day slot seOcc =
let
(day', start, _mEnd) = case seOcc of
Right (Right ScheduleWeekly{..}) -> (scheduleDayOfWeek `dayOfWeekToDayWith` now, scheduleStart, Just scheduleEnd)
Right (Left ExceptOccur{..}) -> (exceptDay, exceptStart, Just exceptEnd)
Right (Left ExceptNoOccur{exceptTime=LocalTime{..}}) -> (localDay, localTimeOfDay, Nothing)
Left ScheduleEntryExamOccurrence{..} -> (seeoDay, seeoStart, seeoEnd)
in day == day' && TimeOfDay slot 0 0 <= start && start < TimeOfDay (slot+slotStep) 0 0
seOccurrenceIsInSlot day slot = \case
Right (Right ScheduleWeekly{..}) -> day == (scheduleDayOfWeek `dayOfWeekToDayWith` now)
&& TimeOfDay slot 0 0 <= scheduleStart
&& scheduleStart < TimeOfDay (slot+slotStep) 0 0
Right (Left ExceptOccur{..}) -> day == exceptDay
&& TimeOfDay slot 0 0 <= exceptStart
&& exceptStart < TimeOfDay (slot+slotStep) 0 0
Right (Left ExceptNoOccur{exceptTime=LocalTime{..}})
-> day == localDay
&& TimeOfDay slot 0 0 <= localTimeOfDay
&& localTimeOfDay < TimeOfDay (slot+slotStep) 0 0
Left ScheduleEntryExamOccurrence{..} -> let slotUTCTime = UTCTime
{ utctDay = utctDay seeoStart
, utctDayTime = timeOfDayToTime (TimeOfDay slot 0 0)
}
nextSlotUTCTime = UTCTime
{ utctDay = utctDay seeoStart
, utctDayTime = timeOfDayToTime (TimeOfDay (slot+slotStep) 0 0)
}
in slotUTCTime <= seeoStart
&& seeoStart < nextSlotUTCTime
events' :: Map Day (Map TimeSlot [ScheduleEntry])
events' = Map.fromList $ currentWeek <&> \day ->
@ -208,7 +221,7 @@ 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 (LocalTime seeoDay seeoStart) (LocalTime seeoDay <$> seeoEnd)
Left ScheduleEntryExamOccurrence{..} -> [whamlet| _{MsgScheduleOccur}: |] <> formatTimeRangeW SelFormatTime seeoStart seeoEnd
-- | Convert from DayOfWeek to Day of this week using the current time (as UTCTime)
dayOfWeekToDayWith :: DayOfWeek -> UTCTime -> Day