diff --git a/frontend/src/app.sass b/frontend/src/app.sass index f651cfb23..2c4e1a45d 100644 --- a/frontend/src/app.sass +++ b/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, diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 12d5b9c02..abf0768af 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index da669150f..159d750c1 100644 --- a/messages/uniworx/en-eu.msg +++ b/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 diff --git a/routes b/routes index 1bb1c3f9a..e6420957e 100644 --- a/routes +++ b/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 diff --git a/src/Application.hs b/src/Application.hs index 490040eed..0325d9ef8 100644 --- a/src/Application.hs +++ b/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 diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index a5d305981..7527dd524 100644 --- a/src/Foundation/Instances.hs +++ b/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) diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index f1e8281c1..c1fbf1e95 100644 --- a/src/Foundation/Navigation.hs +++ b/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 diff --git a/src/Handler/News.hs b/src/Handler/News.hs index 304c33fb3..d4e84c06c 100644 --- a/src/Handler/News.hs +++ b/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 diff --git a/src/Handler/Schedule.hs b/src/Handler/Schedule.hs new file mode 100644 index 000000000..36c1895df --- /dev/null +++ b/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") diff --git a/src/Utils/Schedule/Types.hs b/src/Utils/Schedule/Types.hs index e3f50f581..e22d596d3 100644 --- a/src/Utils/Schedule/Types.hs +++ b/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 diff --git a/src/Utils/Schedule/Week.hs b/src/Utils/Schedule/Week.hs index 5137ad9fc..5db3a5475 100644 --- a/src/Utils/Schedule/Week.hs +++ b/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 diff --git a/templates/news/schedule.hamlet b/templates/news/schedule.hamlet index fb9f1b78a..9a177e431 100644 --- a/templates/news/schedule.hamlet +++ b/templates/news/schedule.hamlet @@ -1,5 +1,5 @@ $newline never

- _{MsgNewsHeadlineSchedule} + _{MsgScheduleTitle} ^{schedule} diff --git a/templates/schedule.hamlet b/templates/schedule.hamlet new file mode 100644 index 000000000..c97c61a85 --- /dev/null +++ b/templates/schedule.hamlet @@ -0,0 +1,6 @@ +$newline never + +
+ ^{optionsWidget} + +^{schedule} diff --git a/templates/schedule/options.hamlet b/templates/schedule/options.hamlet new file mode 100644 index 000000000..8dbde5ead --- /dev/null +++ b/templates/schedule/options.hamlet @@ -0,0 +1,9 @@ +$newline never + + + $forall vWgt <- viewWidgets + ^{fvWidget vWgt} + + + $forall oWgt <- offsetWidgets + ^{fvWidget oWgt} diff --git a/templates/widgets/schedule/week.hamlet b/templates/schedule/week.hamlet similarity index 98% rename from templates/widgets/schedule/week.hamlet rename to templates/schedule/week.hamlet index 7cc1da029..477c40ad3 100644 --- a/templates/widgets/schedule/week.hamlet +++ b/templates/schedule/week.hamlet @@ -1,5 +1,5 @@ $newline never -
+
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index b1a49ec07..a666fe900 100644 --- a/test/Database/Fill.hs +++ b/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