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): major ScheduleEntry type refactor

Browse Source
This commit is contained in:
Sarah Vaupel 2020-08-24 10:57:16 +02:00
parent 280a19865c
commit ed5101c26c
7 changed files with 129 additions and 130 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
models/courses.model
View File

@ -4,7 +4,7 @@ DegreeCourse json -- for which degree programmes this course is appropriate fo
terms StudyTermsId
UniqueDegreeCourse course degree terms
Course -- Information about a single course; contained info is always visible to all users
name (CI Text)
name CourseName
description Html Maybe -- user-defined large Html, ought to contain module description
linkExternal Text Maybe -- arbitrary user-defined url for external course page
shorthand (CI Text) -- practical shorthand of course name, used for identification
@ -29,9 +29,9 @@ Course -- Information about a single course; contained info is always visible
TermSchoolCourseName term school name -- name must be unique within school and semester
deriving Generic
CourseEvent
type (CI Text)
type CourseEventType
course CourseId
room Text
room CourseEventRoom
time Occurrences
note Html Maybe
lastChanged UTCTime default=now()

4
models/exams.model
View File

@ -29,7 +29,7 @@ ExamPart
ExamOccurrence
exam ExamId
name ExamOccurrenceName
room Text
room ExamOccurrenceRoom
capacity Natural
start UTCTime
end UTCTime Maybe
@ -66,4 +66,4 @@ ExamCorrector
ExamPartCorrector
part ExamPartId
corrector ExamCorrectorId
UniqueExamPartCorrector part corrector
UniqueExamPartCorrector part corrector

4
models/tutorials.model
View File

@ -1,7 +1,7 @@
Tutorial json
name TutorialName
course CourseId
type (CI Text) -- "Tutorium", "Zentralübung", ...
type TutorialType -- "Tutorium", "Zentralübung", ...
capacity Int Maybe -- limit for enrolment in this tutorial
room Text Maybe
time Occurrences
@ -20,4 +20,4 @@ Tutor
TutorialParticipant
tutorial TutorialId
user UserId
UniqueTutorialParticipant tutorial user
UniqueTutorialParticipant tutorial user

4
src/Model/Types/Common.hs
View File

@ -36,14 +36,18 @@ type SchoolName = CI Text
type SchoolShorthand = CI Text
type CourseName = CI Text
type CourseShorthand = CI Text
type CourseEventType = CI Text
type CourseEventRoom = Text
type SheetName = CI Text
type MaterialName = CI Text
type UserEmail = CI Email
type UserIdent = CI Text
type TutorialName = CI Text
type TutorialType = CI Text
type ExamName = CI Text
type ExamPartName = CI Text
type ExamOccurrenceName = CI Text
type ExamOccurrenceRoom = Text
type AllocationName = CI Text
type AllocationShorthand = CI Text

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

@ -1,41 +1,28 @@
module Utils.Schedule.Types
( ScheduleEntry(..)
, ScheduleEntryType(..)
, ScheduleEntryRoom
, ScheduleEntryOccurrence
, ScheduleEntryExamOccurrence(..)
) where
import Import
data ScheduleEntry = ScheduleEntry
{ seCourse :: Entity Course -- TODO: just course?; TODO: Maybe?
, seType :: ScheduleEntryType
, seRooms :: [ScheduleEntryRoom] -- multiple rooms in case of multiple parallel exam occurrences,
-- no room in case of no room info (Nothing) for tutorials
-- TODO: encode in ScheduleEntryType instead
, seOccurrence :: ScheduleEntryOccurrence
}
deriving (Generic, Typeable)
data ScheduleEntryType = SETCourseEvent { setceType :: CI Text
} -- TODO: CourseEventType not possible here (comes from data family instance)
| SETTutorial { settType :: CI Text
, settName :: TutorialName
} -- TODO: TutorialType not possible here (comes from data family instance)
| SETExamOccurrence { seteoExamName :: ExamName
}
deriving (Eq, Ord, Show, Read, Generic, Typeable)
type ScheduleEntryRoom = Text
-- TODO: maybe introduce sum new type instead
type ScheduleEntryOccurrence = Either ScheduleEntryExamOccurrence (Either OccurrenceException OccurrenceSchedule)
-- Similar to OccurrenceException, but with Maybe as end
data ScheduleEntryExamOccurrence = ScheduleEntryExamOccurrence
{ seeoStart :: UTCTime
, seeoEnd :: Maybe UTCTime
}
deriving (Eq, Ord, Show, Read, Generic, Typeable)
data ScheduleEntry = ScheduleCourseEvent
{ sceCourse :: Entity Course -- TODO: just course?
, sceType :: CourseEventType
, sceRoom :: CourseEventRoom
, sceOccurrence :: Either OccurrenceException OccurrenceSchedule
}
| ScheduleTutorial
{ stCourse :: Entity Course
, stName :: TutorialName
, stType :: TutorialType
, stRoom :: Maybe Text -- TODO: introduce TutorialRoom type synonym
, stOccurrence :: Either OccurrenceException OccurrenceSchedule
}
| ScheduleExamOccurrence
{ seoCourse :: Entity Course
, seoExamName :: ExamName
, seoRooms :: NonEmpty ExamOccurrenceRoom
, seoStart :: UTCTime
, seoEnd :: Maybe UTCTime
}
deriving (Generic, Typeable)

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

@ -26,6 +26,8 @@ weekSchedule uid dayOffset = do
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
@ -59,7 +61,6 @@ weekSchedule uid dayOffset = do
return (course, tutorial)
-- TODO: this makes the exam table partly redundant => maybe remove?
-- 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.InnerJoin` examOccurrence) -> do
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.on $ exam E.^. ExamId E.==. examOccurrence E.^. ExamOccurrenceExam
@ -74,29 +75,25 @@ weekSchedule uid dayOffset = do
let
courseEventToScheduleEntries :: (Entity Course, Entity CourseEvent) -> [ScheduleEntry]
courseEventToScheduleEntries (seCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType,courseEventRoom,courseEventTime=Occurrences{..}}) =
let seType = SETCourseEvent { setceType = courseEventType }
seRooms = pure $ courseEventRoom
scheduleds
-- omit regular occurrences if the course's term is not currently active
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 seOccurrence = Right (Right scheduled) in ScheduleEntry{..}
| otherwise = Set.toList occurrencesScheduled <&> \scheduled ->
let sceOccurrence = Right scheduled in ScheduleCourseEvent{..}
exceptions = Set.toList occurrencesExceptions <&> \exception ->
let seOccurrence = Right (Left exception) in ScheduleEntry{..}
let sceOccurrence = Left exception in ScheduleCourseEvent{..}
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 }
seRooms = maybe mempty pure tutorialRoom
scheduleds
-- omit regular occurrences if the course's term is not currently active
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 seOccurrence = Right (Right scheduled) in ScheduleEntry{..}
let stOccurrence = Right scheduled in ScheduleTutorial{..}
exceptions = Set.toList occurrencesExceptions <&> \exception ->
let seOccurrence = Right (Left exception) in ScheduleEntry{..}
let stOccurrence = Left exception in ScheduleTutorial{..}
in scheduleds <> exceptions
-- TODO: introduce type synonym for (Entity Course, Entity Exam, Entity ExamOccurrence)?
@ -111,58 +108,68 @@ weekSchedule uid dayOffset = do
&& examOccurrenceStart occ == examOccurrenceStart occ' && examOccurrenceEnd occ == examOccurrenceEnd occ'
examOccurrenceToScheduleEntry :: (Entity Course, Entity Exam, NonEmpty (Entity ExamOccurrence)) -> ScheduleEntry
examOccurrenceToScheduleEntry (seCourse@(Entity _ Course{}), Entity _ Exam{..}, examOccs@((Entity _ occ):|_)) =
let seType = SETExamOccurrence
{ seteoExamName = examName
}
seRooms = toList $ (examOccurrenceRoom . entityVal) <$> examOccs
seOccurrence = Left $ ScheduleEntryExamOccurrence -- multiple exam occurrences are joined on equality
{ seeoStart = examOccurrenceStart occ -- of start and end, so taking the timstamps of the first
, seeoEnd = examOccurrenceEnd occ -- occurrence suffices
}
in 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{..}
seOccurrenceIsInSlot :: Day -> TimeSlot -> ScheduleEntryOccurrence -> Bool
seOccurrenceIsInSlot day slot = \case
Right occurrence -> occDay == day && occTime `isInTimeSlot` slot where
(occDay,occTime) = 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
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 Int [ScheduleEntry])
events' :: Map Day (Map TimeSlot [ScheduleEntry])
events' = Map.fromList $ week <&> \day ->
( day
, Map.fromList $ slotsToDisplay <&> \slot ->
( slot
, filter (seOccurrenceIsInSlot day slot . seOccurrence) $ join $
, filter (seIsInSlot day slot) $ join $
(courseEventToScheduleEntries <$> courseEvents)
<> (tutorialToScheduleEntries <$> tutorials)
<> pure (examOccurrenceToScheduleEntry <$> (joinParallelExamOccurrences examOccurrences))
)
)
events :: Map Day (Map Int [ScheduleEntry])
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 = \case
-- remove regular occurrences if there is a NoOccur exception for the occurrence of this week
ScheduleEntry{seOccurrence=Right (Right ScheduleWeekly{..})} ->
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
Right (Right ScheduleWeekly{..}) -> scheduleDayOfWeek `dayOfWeekToDayWith` now == localDay
&& scheduleStart == localTimeOfDay
_ -> False
) (seOccurrence <$> occurrencesInSlot)
_ -> True -- TODO: maybe filter out ExceptNoOccurs? (Should NoOccurs be displayed or not?)
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)
@ -181,27 +188,26 @@ weekSchedule uid dayOffset = do
-- | 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
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
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 selFormat seeoStart seeoEnd
where selFormat = bool SelFormatDateTime SelFormatTime $ maybe True ((utctDay seeoStart ==) . utctDay) seeoEnd
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 time (as UTCTime)
dayOfWeekToDayWith :: DayOfWeek -> UTCTime -> Day
dayOfWeekToDayWith weekDay = go . utctDay where
-- | 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

46
templates/widgets/schedule/week.hamlet
View File

@ -18,26 +18,28 @@ $newline never
<div .table__td-content>
$maybe dayEvents <- Map.lookup day events
$maybe slotEvents <- Map.lookup slot dayEvents
$forall se@ScheduleEntry{seCourse=Entity _ Course{courseName},seType,seRooms,seOccurrence} <- slotEvents
<a href=@{scheduleEntryToHref se} .schedule--entry-link>
$forall scheduleEntry <- slotEvents
<a href=@{scheduleEntryToHref scheduleEntry} .schedule--entry-link>
<div .schedule--entry>
#{CI.original courseName}: #
$case seType
$of SETCourseEvent{..}
#{CI.original setceType}
$of SETTutorial{..}
#{settName} #
(#{CI.original settType})
$of SETExamOccurrence{..}
#{seteoExamName} #
<br>
$case seRooms
$of []
$of [room]
_{MsgScheduleRoom}: #{room}
$of rooms
_{MsgScheduleRooms}: #{intercalate ", " rooms}
<br>
^{formatOccurrenceW seOccurrence}
$case scheduleEntry
$of ScheduleCourseEvent{sceCourse=Entity _ Course{courseName},sceType,sceRoom,sceOccurrence}
#{CI.original courseName}: #{CI.original sceType} <br/>
_{MsgScheduleRoom}: #{sceRoom} <br/>
^{formatEitherOccurrenceW sceOccurrence}
$of ScheduleTutorial{stCourse=Entity _ Course{courseName},stName,stType,stRoom,stOccurrence}
#{CI.original courseName}: #{stName} (#{CI.original stType}) <br/>
_{MsgScheduleRoom}: #{stRoom} <br/>
^{formatEitherOccurrenceW stOccurrence}
$of ScheduleExamOccurrence{seoCourse=Entity _ Course{courseName},seoExamName,seoRooms,seoStart,seoEnd}
#{CI.original courseName}: #{seoExamName} <br/>
$case toList seoRooms
$of [room]
_{MsgScheduleRoom}: #{room}
$of more
_{MsgScheduleRooms}: #{intercalate ", " more}
<br>
_{MsgScheduleOccur}: #
$if Just (utctDay seoStart) == fmap utctDay seoEnd
^{formatTimeRangeW SelFormatTime seoStart seoEnd}
$else
^{formatTimeRangeW SelFormatDateTime seoStart seoEnd}