feat(schedule): first (not-yet-working) stub for ScheduleR

frontend/src/app.sass

@@ -288,6 +288,8 @@ button[disabled]:not(.btn-link),
   opacity: 0.3
   background-color: var(--color-grey)
   cursor: default
+  .tooltip__handle
+    cursor: default
 
 input[type="submit"]:not([disabled]):not(.btn-link):hover,
 input[type="button"]:not([disabled]):not(.btn-link):hover,

messages/uniworx/de-de-formal.msg

@@ -102,7 +102,16 @@ TermLectureEndTooltip: Meistens dauer das Sommersemester 14 Wochen und das Winte
 TermActive: Aktiv
 
 
-NewsHeadlineSchedule: Terminübersicht
+ScheduleTitle: Terminübersicht
+
+ScheduleView: Ansicht
+ScheduleViewWeek: Woche
+
+ScheduleOffsetWeekBackwardWeek: 1 Woche zurück
+ScheduleOffsetWeekBackwardDay: 1 Tag zurück
+ScheduleOffsetWeekCurrent: Zu aktueller Woche springen
+ScheduleOffsetWeekForwardDay: 1 Tag vorwärts
+ScheduleOffsetWeekForwardWeek: 1 Woche vorwärts
 
 ScheduleTableHeadTime: Zeit
 
@@ -1293,6 +1302,7 @@ MenuUserNotifications: Benachrichtigungs-Einstellungen
 MenuUserPassword: Passwort
 MenuAdminTest: Admin-Demo
 MenuMessageList: Systemnachrichten
+MenuSchedule: Terminübersicht
 MenuAdminErrMsg: Fehlermeldung entschlüsseln
 MenuAdminTokens: Tokens ausstellen
 MenuProfileData: Persönliche Daten
@@ -1625,6 +1635,7 @@ InvitationCollision: Einladung konnte nicht angenommen werden da ein derartiger
 InvitationDeclined: Einladung wurde abgelehnt
 BtnInviteAccept: Einladung annehmen
 BtnInviteDecline: Einladung ablehnen
+BtnScheduleViewWeek: Woche
 
 LecturerType: Rolle
 ScheduleKindWeekly: Wöchentlich

messages/uniworx/en-eu.msg

@@ -37,6 +37,7 @@ BtnAllocationCompute: Compute allocation
 BtnAllocationAccept: Accept allocation
 BtnSystemMessageHide: Hide
 BtnSystemMessageUnhide: Unhide
+BtnScheduleViewWeek: Week
 
 BtnCommunicationSend: Send
 BtnCommunicationTest: Send test message
@@ -102,7 +103,16 @@ TermLectureEndTooltip: Summer semesters are usually 14 weeks; winter semesters 1
 TermActive: Active
 
 
-NewsHeadlineSchedule: Schedule
+ScheduleTitle: Schedule
+
+ScheduleView: View
+ScheduleViewWeek: Week
+
+ScheduleOffsetWeekBackwardWeek: 1 week back
+ScheduleOffsetWeekBackwardDay: 1 day back
+ScheduleOffsetWeekCurrent: Jump to current week
+ScheduleOffsetWeekForwardDay: 1 day forward
+ScheduleOffsetWeekForwardWeek: 1 week forward
 
 ScheduleTableHeadTime: Time
 
@@ -1293,6 +1303,7 @@ MenuUserNotifications: Notification settings
 MenuUserPassword: Password
 MenuAdminTest: Admin-demo
 MenuMessageList: System messages
+MenuSchedule: Schedule
 MenuAdminErrMsg: Decrypt error message
 MenuAdminTokens: Issue tokens
 MenuProfileData: Personal information

routes

@@ -231,6 +231,10 @@
 /msg/#{CryptoUUIDSystemMessage}      MessageR      GET POST        !timeANDreadANDauthentication
 /msg/#{CryptoUUIDSystemMessage}/hide MessageHideR      POST        !timeANDauthentication
 
+
+/schedule  ScheduleR  GET POST  !free
+
+
 !/#UUID CryptoUUIDDispatchR GET                               !free -- just redirect
 -- !/*{CI FilePath} CryptoFileNameDispatchR GET                  !free -- Disabled until preliminary check for valid cID exists
 

src/Application.hs

@@ -120,6 +120,7 @@ import Handler.Tutorial
 import Handler.Material
 import Handler.CryptoIDDispatch
 import Handler.SystemMessage
+import Handler.Schedule
 import Handler.Health
 import Handler.Exam
 import Handler.Allocation

src/Foundation/Instances.hs

@@ -51,6 +51,7 @@ data instance ButtonClass UniWorX
   | BCDanger
   | BCLink
   | BCMassInputAdd | BCMassInputDelete
+  | BCScheduleView | BCScheduleOffset
   deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
   deriving anyclass (Universe, Finite)
 

src/Foundation/Navigation.hs

@@ -309,6 +309,8 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
   breadcrumb MessageListR = i18nCrumb MsgMenuMessageList $ Just AdminR
   breadcrumb (MessageHideR cID) = i18nCrumb MsgBreadcrumbMessageHide . Just $ MessageR cID
 
+  breadcrumb ScheduleR = i18nCrumb MsgMenuSchedule Nothing
+
   breadcrumb GlossaryR = i18nCrumb MsgMenuGlossary $ Just InfoR
 
   breadcrumb EExamListR = i18nCrumb MsgMenuExternalExamList Nothing

src/Handler/News.hs

@@ -7,6 +7,7 @@ import Handler.Utils.News
 
 import Handler.SystemMessage
 
+import Utils.Schedule.Types (ScheduleOffset(..))
 import Utils.Schedule.Week
 
 import qualified Data.Map as Map
@@ -86,10 +87,9 @@ 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)
+-- TODO: deprecated; update once ScheduleR is finished
 newsSchedule :: UserId -> Widget
-newsSchedule uid = let schedule = weekSchedule uid Nothing in $(widgetFile "news/schedule")
+newsSchedule uid = let schedule = weekSchedule uid ScheduleOffsetNone in $(widgetFile "news/schedule")
 
 
 newsUpcomingSheets :: UserId -> Widget

src/Handler/Schedule.hs

@@ -0,0 +1,117 @@
+module Handler.Schedule
+  ( getScheduleR, postScheduleR
+  ) where
+
+import Import
+
+--import qualified Data.Map as Map
+--import qualified Data.Set as Set
+
+import Handler.Utils.Form
+--import Utils.Form
+
+-- TODO: move Utils.Schedule to Handler.Utils.Schedule?
+import Utils.Schedule.Types
+import Utils.Schedule.Week
+
+
+data ScheduleGetParam = ScheduleGetView | ScheduleGetOffset
+  deriving (Eq, Ord, Enum, Show, Read, Generic, Typeable)
+
+instance PathPiece ScheduleGetParam where
+  toPathPiece = (camelToPathPiece' 2) . tshow
+  fromPathPiece "view" = Just ScheduleGetView
+  fromPathPiece "offset" = Just ScheduleGetOffset
+  fromPathPiece _ = Nothing
+
+
+-- TODO: remove
+--type ScheduleOffsetInfo = ( ScheduleOffset        -- offset value
+--                          , Icon                  -- button icon for display
+--                          , Maybe UniWorXMessage  -- message to display when hovering over the button
+--                          )
+
+-- TODO: remove
+--scheduleViewOffsets :: Map ScheduleView [ScheduleOffsetInfo] --  (Set ScheduleOffsetInfo)
+--scheduleViewOffsets = Map.fromList $  -- (\(k,v) -> (k, Set.fromList v)) <$>
+--  [ ( ScheduleViewWeek
+--    , [ (ScheduleOffsetDays (-7), IconFastBackward, Just MsgScheduleOffsetWeekBackwardWeek)
+--      , (ScheduleOffsetDays (-1), IconBackward,     Just MsgScheduleOffsetWeekBackwardDay )
+--      , (ScheduleOffsetNone     , IconCurrent,      Just MsgScheduleOffsetWeekCurrent     )
+--      , (ScheduleOffsetDays   1 , IconForward,      Just MsgScheduleOffsetWeekForwardDay  )
+--      , (ScheduleOffsetDays   7 , IconFastForward,  Just MsgScheduleOffsetWeekForwardWeek )
+--      ]
+--    )
+--  ]
+
+-- TODO: remove
+--iconTooltipMessage :: Icon -> UniWorXMessage -> Widget
+--iconTooltipMessage ico msg = iconTooltip [whamlet| _{msg} |] (Just ico) True
+
+addOffsets :: ScheduleOffset -> ScheduleOffset -> ScheduleOffset
+addOffsets ScheduleOffsetNone offset = offset
+addOffsets offset ScheduleOffsetNone = offset
+addOffsets (ScheduleOffsetDays d) (ScheduleOffsetDays d') = ScheduleOffsetDays $ d + d'
+
+
+getScheduleR, postScheduleR :: Handler Html
+getScheduleR = postScheduleR
+postScheduleR = do
+  uid <- requireAuthId
+  -- mr <- getMessageRender
+  
+  let
+    -- TODO: persist default schedule view (week, month, ...) in user settings, lookup default and choose schedule accordingly
+    defaultScheduleOptions :: ScheduleOptions
+    defaultScheduleOptions = ScheduleOptions
+                             { scheduleView   = ScheduleViewWeek
+                             , scheduleOffset = ScheduleOffsetNone
+                             }
+
+    -- TODO: lookup get param, if not present take default
+    currentScheduleView :: ScheduleView
+    currentScheduleView = scheduleView defaultScheduleOptions
+
+    -- TODO: lookup get param, if not present take default
+    currentScheduleOffset :: ScheduleOffset
+    currentScheduleOffset = scheduleOffset defaultScheduleOptions
+
+    offsetFromWeekBtn :: ButtonScheduleOffsetWeek -> ScheduleOffset
+    offsetFromWeekBtn BtnSOWCurrent = ScheduleOffsetNone
+    offsetFromWeekBtn btn           = currentScheduleOffset `addOffsets` btnOffset where
+      btnOffset = case btn of
+        BtnSOWBackwardWeek -> ScheduleOffsetDays (-7)
+        BtnSOWBackwardDay  -> ScheduleOffsetDays (-1)
+        BtnSOWForwardDay   -> ScheduleOffsetDays   1
+        BtnSOWForwardWeek  -> ScheduleOffsetDays   7
+        _                  -> ScheduleOffsetNone
+
+    scheduleOptionsForm :: MForm (HandlerFor UniWorX) (FormResult ScheduleOptions, Widget)
+    scheduleOptionsForm = do
+      (_viewRess, viewWidgets) <- fmap unzip . for (universeF :: [ScheduleView]) $ \sView ->
+        mopt (buttonField sView) ("" { fsName  = Just $ toPathPiece ScheduleGetView
+                                     , fsAttrs = if sView == currentScheduleView then [("disabled","")] else mempty
+                                     }) Nothing
+      -- TODO: choose offset button set according to viewRess
+      (_offsetRess, offsetWidgets) <- fmap unzip . for (universeF :: [ButtonScheduleOffsetWeek]) $ \sOffsetBtn ->
+        mopt (buttonField sOffsetBtn) ("" { fsName  = Just $ toPathPiece ScheduleGetOffset
+                                          , fsAttrs = if offsetFromWeekBtn sOffsetBtn == currentScheduleOffset then [("disabled","")] else mempty
+                                          }) Nothing
+
+      -- TODO: use viewRess and offsetRess
+      let
+        scheduleResult = ScheduleOptions <$> FormSuccess ScheduleViewWeek <*> FormSuccess ScheduleOffsetNone
+        optionsWidget = $(widgetFile "schedule/options")
+      
+      return (scheduleResult, optionsWidget)
+
+  ((optionsRes, optionsWidget), optionsEnctype) <- runFormGet $ const scheduleOptionsForm
+
+  let
+    schedule = case optionsRes of
+      FormSuccess ScheduleOptions{scheduleView=ScheduleViewWeek,..} -> weekSchedule uid scheduleOffset
+      _ -> mempty  -- TODO: don't swallow errors!
+
+  siteLayoutMsg MsgMenuSchedule $ do
+    setTitleI MsgMenuSchedule
+    $(widgetFile "schedule")

src/Utils/Schedule/Types.hs

@@ -4,15 +4,22 @@ module Utils.Schedule.Types
   , ScheduleExamOccurrenceInfo
   , ScheduleExamOccurrenceJoinedInfo
   , ScheduleEntry(..)
+  , ScheduleOptions(..)
+  , ScheduleView(..)
+  , ScheduleOffset(..)
+  , ButtonScheduleOffsetWeek(..)
   ) where
 
 import Import
 
+import Handler.Utils
 
-type ScheduleCourseEventInfo = (Entity Course, Entity CourseEvent)
+import Web.PathPieces (readFromPathPiece)
 
-type ScheduleTutorialInfo = (Entity Course, Entity Tutorial)
 
+-- TODO: replace Info types with one joined type and fetch info in one single runDB
+type ScheduleCourseEventInfo          = (Entity Course, Entity CourseEvent)
+type ScheduleTutorialInfo             = (Entity Course, Entity Tutorial)
 type ScheduleExamOccurrenceInfo       = (Entity Course, Entity Exam, Entity ExamOccurrence)
 type ScheduleExamOccurrenceJoinedInfo = (Entity Course, Entity Exam, NonEmpty (Entity ExamOccurrence))
 
@@ -36,4 +43,93 @@ data ScheduleEntry = ScheduleCourseEvent
                      , seoStart      :: UTCTime
                      , seoEnd        :: Maybe UTCTime
                      }
-                   deriving (Generic, Typeable)
+  deriving (Generic, Typeable)
+
+
+data ScheduleOptions = ScheduleOptions
+                       { scheduleView   :: ScheduleView
+                       , scheduleOffset :: ScheduleOffset
+                       }
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+
+
+data ScheduleView = ScheduleViewWeek
+  deriving (Eq, Ord, Enum, Show, Read, Generic, Typeable)
+
+instance Bounded ScheduleView where
+  minBound = maxBound
+  maxBound = ScheduleViewWeek
+instance Finite ScheduleView
+instance Universe ScheduleView
+
+instance PathPiece ScheduleView where
+  toPathPiece          = camelToPathPiece' 2 . tshow
+  fromPathPiece "week" = Just ScheduleViewWeek
+  fromPathPiece _      = Nothing
+
+instance Button UniWorX ScheduleView where
+  btnClasses ScheduleViewWeek = [BCIsButton, BCScheduleView]
+  btnLabel   ScheduleViewWeek = [whamlet| _{MsgBtnScheduleViewWeek} |]
+
+
+data ScheduleOffset = ScheduleOffsetNone
+                    | ScheduleOffsetDays   Int
+                    -- | ScheduleOffsetMonths Int
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+
+instance PathPiece ScheduleOffset where
+  toPathPiece  ScheduleOffsetNone      = "none"
+  toPathPiece (ScheduleOffsetDays   d) = tshow d <> "d"
+  --toPathPiece (ScheduleOffsetMonths m) = tshow m <> "m"
+  fromPathPiece "none" = Just ScheduleOffsetNone
+  fromPathPiece t
+    | Just t' <- fromNullable t
+    , Just n  <- readFromPathPiece (init t') = case last t' of
+      'd' -> Just $ ScheduleOffsetDays   n
+      --'m' -> Just $ ScheduleOffsetMonths n
+      _   -> Nothing
+    | otherwise = Nothing
+
+data ButtonScheduleOffsetWeek = BtnSOWBackwardWeek
+                              | BtnSOWBackwardDay
+                              | BtnSOWCurrent
+                              | BtnSOWForwardDay
+                              | BtnSOWForwardWeek
+  deriving (Eq, Ord, Enum, Show, Read, Generic, Typeable)
+
+instance Bounded ButtonScheduleOffsetWeek where
+  minBound = BtnSOWBackwardWeek
+  maxBound = BtnSOWForwardWeek
+instance Finite ButtonScheduleOffsetWeek
+instance Universe ButtonScheduleOffsetWeek
+
+instance PathPiece ButtonScheduleOffsetWeek where
+  toPathPiece BtnSOWCurrent = toPathPiece ScheduleOffsetNone
+  toPathPiece btn           = toPathPiece $ ScheduleOffsetDays d where
+    d = case btn of
+      BtnSOWBackwardWeek -> (-7)
+      BtnSOWBackwardDay  -> (-1)
+      BtnSOWForwardDay   ->   1
+      BtnSOWForwardWeek  ->   7
+      _                  ->   0
+  fromPathPiece t = case (fromPathPiece :: Text -> Maybe ScheduleOffset) t of
+    Just  ScheduleOffsetNone    -> Just BtnSOWCurrent
+    Just (ScheduleOffsetDays d) -> case d of
+      (-7) -> Just BtnSOWBackwardWeek
+      (-1) -> Just BtnSOWBackwardDay
+      0    -> Just BtnSOWCurrent
+      1    -> Just BtnSOWForwardDay
+      7    -> Just BtnSOWForwardWeek
+      _    -> Nothing
+    _ -> Nothing
+
+instance Button UniWorX ButtonScheduleOffsetWeek where
+  btnClasses = const [BCIsButton, BCScheduleOffset]
+  btnLabel btn = [whamlet| ^{iconTooltipMessage ico tip} |] where
+    (ico, tip) = case btn of
+      BtnSOWBackwardWeek -> (IconFastBackward , MsgScheduleOffsetWeekBackwardWeek)
+      BtnSOWBackwardDay  -> (IconBackward     , MsgScheduleOffsetWeekBackwardDay )
+      BtnSOWCurrent      -> (IconCurrent      , MsgScheduleOffsetWeekCurrent     )
+      BtnSOWForwardDay   -> (IconForward      , MsgScheduleOffsetWeekForwardDay  )
+      BtnSOWForwardWeek  -> (IconFastForward  , MsgScheduleOffsetWeekForwardWeek )
+    iconTooltipMessage i m = iconTooltip [whamlet| _{m} |] (Just i) True

src/Utils/Schedule/Week.hs

@@ -18,13 +18,18 @@ import Utils.Schedule.Types
 import Utils.Schedule.Week.TimeSlot
 
 
-weekSchedule :: UserId -> Maybe Integer -> Widget
-weekSchedule uid dayOffset = do
+weekSchedule :: UserId -> ScheduleOffset -> Widget
+weekSchedule uid scheduleOffset = do
   now <- liftIO getCurrentTime
   tz  <- liftIO getCurrentTimeZone
   ata <- getSessionActiveAuthTags
 
-  let dayNowOffset = fromMaybe 0 dayOffset `addDays` utctDay now
+  let
+    dayOffset = case scheduleOffset of
+      ScheduleOffsetNone     -> 0
+      ScheduleOffsetDays   d -> d
+      -- ScheduleOffsetMonths _ -> 0  -- TODO: month offset currently not supported
+    dayNowOffset = toInteger dayOffset `addDays` utctDay now
 
   -- TODO: single runDB for all fetches below?
   
@@ -115,7 +120,7 @@ weekSchedule uid dayOffset = do
       where go day
               | dayOfWeek day == firstDay = [day .. toEnum (fromEnum day + 6)]
               | otherwise = go $ pred day
-            firstDay = toEnum $ fromEnum Monday + fromInteger (fromMaybe 0 dayOffset)
+            firstDay = toEnum $ fromEnum Monday + dayOffset
 
     -- TODO: make this configurable
     timeSlotsDefaultDisplay :: Set TimeSlot
@@ -127,7 +132,7 @@ weekSchedule uid dayOffset = do
     timeSlotIsEmpty :: TimeSlot -> Bool
     timeSlotIsEmpty slot = foldr (\day acc -> acc && maybe True null (day Map.!? slot)) True events
 
-  $(widgetFile "widgets/schedule/week")
+  $(widgetFile "schedule/week")
 
 
 -- Local helper functions

templates/news/schedule.hamlet

@@ -1,5 +1,5 @@
 $newline never
 <section>
   <h2>
-    _{MsgNewsHeadlineSchedule}
+    _{MsgScheduleTitle}
   ^{schedule}

templates/schedule.hamlet

@@ -0,0 +1,6 @@
+$newline never
+
+<form enctype=#{optionsEnctype} .schedule-options>
+  ^{optionsWidget}
+
+^{schedule}

templates/schedule/options.hamlet

@@ -0,0 +1,9 @@
+$newline never
+
+<span .schedule-options__view-group>
+  $forall vWgt <- viewWidgets
+    ^{fvWidget vWgt}
+
+<span .schedule-options__offset-group>
+  $forall oWgt <- offsetWidgets
+    ^{fvWidget oWgt}

templates/schedule/week.hamlet

@@ -1,5 +1,5 @@
 $newline never
-<div uw-hide-columns="schedule-week">
+<div .schedule uw-hide-columns="schedule-week">
   <table .table .table--striped .table--hover .schedule>
     <thead>
       <tr .table__row .table__row--head>

test/Database/Fill.hs

@@ -239,7 +239,7 @@ fillDb = do
     , userAuthentication = AuthLDAP
     , userLastAuthentication = Nothing
     , userTokensIssuedAfter = Nothing
-    , userMatrikelnummer = Nothing
+    , userMatrikelnummer = Just "11323801"
     , userEmail  = "vaupel.sarah@campus.lmu.de"
     , userDisplayEmail = "vaupel.sarah@campus.lmu.de"
     , userDisplayName = "Sarah Vaupel"
@@ -248,7 +248,7 @@ fillDb = do
     , userTitle = Nothing
     , userMaxFavourites = 14
     , userMaxFavouriteTerms = 4
-    , userTheme = ThemeMossGreen
+    , userTheme = ThemeNeutralBlue
     , userDateTimeFormat = userDefaultDateTimeFormat
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat