From 6b585f8dae68215a301957b23a8ba0db7729ac2b Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Wed, 19 Aug 2020 23:10:23 +0200 Subject: [PATCH] chore(schedule): add first WIP stub --- frontend/src/app.sass | 13 +++ messages/uniworx/de-de-formal.msg | 24 +++++ messages/uniworx/en-eu.msg | 24 +++++ src/Handler/News.hs | 9 ++ src/Utils/Schedule.hs | 124 +++++++++++++++++++++++++ src/Utils/Schedule/Types.hs | 23 +++++ templates/widgets/schedule/week.hamlet | 48 ++++++++++ 7 files changed, 265 insertions(+) create mode 100644 src/Utils/Schedule.hs create mode 100644 src/Utils/Schedule/Types.hs create mode 100644 templates/widgets/schedule/week.hamlet diff --git a/frontend/src/app.sass b/frontend/src/app.sass index ae859585b..94560d1fb 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -1380,3 +1380,16 @@ a.breadcrumbs__home .multi-user-invitation-field__wrapper max-width: 25rem + + +table.schedule + .schedule--entry + background-color: var(--color-dark) + color: white + font-weight: 600 + border-radius: 15px + padding: 10px + a.schedule--entry-link + text-decoration: none + a.schedule--entry-link + a.schedule--entry-link > .schedule--entry + margin-top: 5px diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 8f8f5ccfd..06a91d75c 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -102,6 +102,30 @@ TermLectureEndTooltip: Meistens dauer das Sommersemester 14 Wochen und das Winte TermActive: Aktiv +ScheduleHeadline: Terminübersicht + +ScheduleTableHeadTime: Zeit + +ScheduleRoom: Raum +ScheduleTime: Zeit + +ScheduleWeekDayMonday: Montag +ScheduleWeekDayTuesday: Dienstag +ScheduleWeekDayWednesday: Mittwoch +ScheduleWeekDayThursday: Donnerstag +ScheduleWeekDayFriday: Freitag +ScheduleWeekDaySaturday: Samstag +ScheduleWeekDaySunday: Sonntag + +ScheduleWeekDayMondayShort: Mo +ScheduleWeekDayTuesdayShort: Di +ScheduleWeekDayWednesdayShort: Mi +ScheduleWeekDayThursdayShort: Do +ScheduleWeekDayFridayShort: Fr +ScheduleWeekDaySaturdayShort: Sa +ScheduleWeekDaySundayShort: So + + SchoolListHeading: Übersicht über verwaltete Institute SchoolHeading school@SchoolName: Übersicht #{school} diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index bb7d7e9ce..8ad7417ae 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -102,6 +102,30 @@ TermLectureEndTooltip: Summer semesters are usually 14 weeks; winter semesters 1 TermActive: Active +ScheduleHeadline: Schedule + +ScheduleTableHeadTime: Time + +ScheduleRoom: Room +ScheduleTime: Time + +ScheduleWeekDayMonday: Monday +ScheduleWeekDayTuesday: Tuesday +ScheduleWeekDayWednesday: Wednesday +ScheduleWeekDayThursday: Thursday +ScheduleWeekDayFriday: Friday +ScheduleWeekDaySaturday: Saturday +ScheduleWeekDaySunday: Sunday + +ScheduleWeekDayMondayShort: Mon +ScheduleWeekDayTuesdayShort: Tue +ScheduleWeekDayWednesdayShort: Wed +ScheduleWeekDayThursdayShort: Thu +ScheduleWeekDayFridayShort: Fri +ScheduleWeekDaySaturdayShort: Sat +ScheduleWeekDaySundayShort: Sun + + SchoolListHeading: Department SchoolHeading school: #{school} diff --git a/src/Handler/News.hs b/src/Handler/News.hs index 04ee47d74..88aef9395 100644 --- a/src/Handler/News.hs +++ b/src/Handler/News.hs @@ -7,6 +7,8 @@ import Handler.Utils.News import Handler.SystemMessage +import Utils.Schedule + import qualified Data.Map as Map import Database.Esqueleto.Utils.TH import qualified Database.Esqueleto as E @@ -32,6 +34,7 @@ getNewsR = do case muid of Just uid -> do + newsSchedule uid newsUpcomingExams uid newsUpcomingSheets uid Nothing -> @@ -83,6 +86,12 @@ newsSystemMessages = do $(widgetFile "news/system-messages") +-- TODO: persist default schedule in user settings, lookup default and choose schedule accordingly +-- TODO: add action to switch schedule (replace widget) +newsSchedule :: UserId -> Widget +newsSchedule = weekSchedule + + newsUpcomingSheets :: UserId -> Widget newsUpcomingSheets uid = do cTime <- liftIO getCurrentTime diff --git a/src/Utils/Schedule.hs b/src/Utils/Schedule.hs new file mode 100644 index 000000000..25cbfbc9c --- /dev/null +++ b/src/Utils/Schedule.hs @@ -0,0 +1,124 @@ +module Utils.Schedule + ( 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 Handler.Utils.DateTime (formatTimeRangeW) + +import Utils.Schedule.Types +import Utils.Course (mayViewCourse) + + +-- TODO: very temporary slot representation +type TimeSlot = Int +firstSlot, lastSlot, slotStep :: Int +firstSlot = 8 +lastSlot = 20 +slotStep = 2 + +slotsToDisplay :: [TimeSlot] +slotsToDisplay = [firstSlot,firstSlot+slotStep..lastSlot] + +slotToDisplayTime :: TimeSlot -> Widget +slotToDisplayTime t = formatTimeRangeW SelFormatTime (TimeOfDay t 0 0) $ Just $ TimeOfDay (t + slotStep) 0 0 + + +weekSchedule :: UserId -> Widget +weekSchedule uid = do + now <- liftIO getCurrentTime + ata <- getSessionActiveAuthTags + + -- TODO: single runDB for every fetch below? + + -- 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 + 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 + ) 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) + + -- TODO: fetch registered tutorials + -- TODO: also fetch tutorials with user as tutor + _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.||. (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: fetch exam occurrences for exam participants and lecturers + let _exams = [] + + 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 + + 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 + + -- TODO: use NonEmpty ScheduleEntry instead of [ScheduleEntry] + courseEvents :: Map DayOfWeek (Map TimeSlot [ScheduleEntry]) + courseEvents = Map.fromList $ [Monday .. Sunday] <&> \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 + ) + ) + + -- 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") + ] + + $(widgetFile "widgets/schedule/week") diff --git a/src/Utils/Schedule/Types.hs b/src/Utils/Schedule/Types.hs new file mode 100644 index 000000000..6a325b4c9 --- /dev/null +++ b/src/Utils/Schedule/Types.hs @@ -0,0 +1,23 @@ +module Utils.Schedule.Types + ( ScheduleEntry(..) + , ScheduleEntryType(..) + , ScheduleEntryRoom + ) where + +import Import + + +data ScheduleEntry = ScheduleEntry + { seCourse :: Entity Course -- TODO: just course?; TODO: Maybe? + , seType :: ScheduleEntryType + , seRoom :: ScheduleEntryRoom + , seOccurrences :: Occurrences -- TODO: will require converting exam occurrences to an ExceptOccur OccurrenceException + } + +data ScheduleEntryType = SETCourseEvent { setceType :: CI Text } -- TODO: CourseEventType not possible here (comes from data family instance) + | SETTutorial { settType :: CI Text } -- TODO: TutorialType not possible here (comes from data family instance) + | SETExamOccurrence { seteoExamName :: ExamName } + -- TODO: more? + deriving (Eq, Ord, Show, Read, Generic, Typeable) + +type ScheduleEntryRoom = Maybe Text -- TODO: is Maybe Text okay for every ScheduleEntryType? diff --git a/templates/widgets/schedule/week.hamlet b/templates/widgets/schedule/week.hamlet new file mode 100644 index 000000000..3db49b061 --- /dev/null +++ b/templates/widgets/schedule/week.hamlet @@ -0,0 +1,48 @@ +$newline never +
+

+ _{MsgScheduleHeadline} + +
+ + + + + $forall slot <- slotsToDisplay + +
+ _{MsgScheduleTableHeadTime} + $forall (_, weekDayTitle, weekDayIdent) <- weekDays + + _{weekDayTitle} +
+ ^{slotToDisplayTime slot} + $forall (weekDay, _, _) <- weekDays + +