From ff9916fde6c8ccdd4a0217116a498ba61477988d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 11 Nov 2020 14:04:54 +0100 Subject: [PATCH] refactor(schedule): (type) cleanup --- config/settings.yml | 8 +-- messages/uniworx/de-de-formal.msg | 12 ++--- messages/uniworx/en-eu.msg | 12 ++--- models/users.model | 10 ++-- src/Handler/Profile.hs | 59 ++++++--------------- src/Handler/Utils/Form.hs | 2 +- src/Model/Migration.hs | 2 + src/Model/Types/DateTime.hs | 12 +++++ src/Model/Types/Misc.hs | 20 ------- src/Settings.hs | 4 +- src/Utils.hs | 15 ++++++ src/Utils/DateTime.hs | 7 +++ src/Utils/Form.hs | 24 ++++++++- src/Utils/Schedule/Types/ScheduleView.hs | 7 ++- src/Utils/Schedule/Week.hs | 11 ++-- src/Utils/Schedule/Week/TimeSlot.hs | 64 ++++++++++++++--------- src/Utils/Schedule/Week/Types/TimeSlot.hs | 10 ++-- templates/schedule/options.hamlet | 5 +- templates/schedule/week.hamlet | 2 +- 19 files changed, 158 insertions(+), 128 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 069b35358..fd1b4bccb 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -214,11 +214,11 @@ user-defaults: download-files: false warning-days: 1209600 show-sex: false - schedule-view: view-week + schedule-view: week schedule-week-days: [Monday,Tuesday,Wednesday,Thursday,Friday] - schedule-week-time-from: 8 - schedule-week-time-to: 18 - schedule-week-timeslot-length: 2 + schedule-week-time-from: 28800 # 08:00 + schedule-week-time-to: 72000 # 20:00 + schedule-week-timeslot-length: 7200 # 2h schedule-occurrence-display-default: true # During central allocations lecturer-given ratings of applications (as diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 52c3e656f..204a4a4c2 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -115,14 +115,14 @@ ProfileScheduleViewTip: Betrifft die Terminübersicht auf „Aktuelles“ und ScheduleWeekDays: In der Wochenansicht dargestellte Wochentage ScheduleWeekDaysTip: Wochentage, welche standardmäßig in der Wochenansicht dargestellt werden. Gibt es einen darzustellenden Termin, der auf einen Wochentag fällt welcher hier nicht gesetzt ist, so wird der jeweilige Wochentag als zusätzliche Spalte angezeigt. -ScheduleWeekTimeFrom: Beginn (Stunde) des ersten in der Wochenansicht dargestellten Zeitslots -ScheduleWeekTimeFromTip: Stunde, zu welcher der erste in der Wochenansicht dargestellte Zeitslot beginnt. Gibt es einen darzustellenden Termin, der in einem Zeitslot vor dem hier angegebenen Zeitslot liegt, so wird der jeweilige Zeitslot als zusätzliche Zeile vor dem hier angegeben Zeitslot angezeigt. +ScheduleWeekTimeFrom: Beginn des ersten in der Wochenansicht dargestellten Zeitslots +ScheduleWeekTimeFromTip: Zeitpunkt, zu welchem der erste in der Wochenansicht dargestellte Zeitslot beginnt. Gibt es einen darzustellenden Termin, der in einem Zeitslot vor dem hier angegebenen Zeitslot liegt, so wird der jeweilige Zeitslot als zusätzliche Zeile vor dem hier angegeben Zeitslot angezeigt. ScheduleWeekTimeFromPlaceholder: Erster Zeitslot -ScheduleWeekTimeTo: Beginn (Stunde) des letzten in der Wochenansicht dargestellten Zeitslots -ScheduleWeekTimeToTip: Stunde, zu welcher der letzte in der Wochenansicht dargestellte Zeitslot beginnt. Gibt es einen darzustellenden Termin, der in einem Zeitslot nach dem hier angegebenen Zeitslot liegt, so wird der jeweilige Zeitslot als zusätzliche Zeile nach dem hier angegebenen Zeitslot angezeigt. +ScheduleWeekTimeTo: Ende des letzten in der Wochenansicht dargestellten Zeitslots +ScheduleWeekTimeToTip: Zeitpunkt, zu welchem der letzte in der Wochenansicht dargestellte Zeitslot endet. Gibt es einen darzustellenden Termin, der in einem Zeitslot nach dem hier angegebenen Zeitslot liegt, so wird der jeweilige Zeitslot als zusätzliche Zeile nach dem hier angegebenen Zeitslot angezeigt. ScheduleWeekTimeToPlaceholder: Letzter Zeitslot -ScheduleWeekTimeslotLength: Länge (in Stunden) der in der Wochenansicht dargestellten Zeitslots -ScheduleWeekTimeslotLengthTip: Die Länge (in Stunden) jedes in der Wochenansicht der Terminübersicht als separate Zeile dargestellten Zeitslots +ScheduleWeekTimeslotLength: Länge (in Minuten) der in der Wochenansicht dargestellten Zeitslots +ScheduleWeekTimeslotLengthTip: Die Länge (in Minuten) jedes in der Wochenansicht der Terminübersicht als separate Zeile dargestellten Zeitslots ScheduleWeekTimeslotLengthPlaceholder: Zeitslotlänge ScheduleWeekTimeFromMustBeAValidTime n@Int: Erster Zeitslot der Wochenansicht muss zwischen 0 und #{n} liegen diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 7a8855423..bfc9e5f3c 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -116,14 +116,14 @@ ProfileScheduleViewTip: Relevant for the schedule on "News" and "Schedule". (Mor ScheduleWeekDays: Weekdays to display in the weekly schedule ScheduleWeekDaysTip: Weekdays to display by default in the weekly schedule. If there is an occurrence to display which occurs on a weekday that is not set here, the weekday will be displayed as a separate column regardless. -ScheduleWeekTimeFrom: Start (hour) of the first timeslot to display in the weekly schedule -ScheduleWeekTimeFromTip: The hour at which the first timeslot to display in the weekly schedule begins. If there is an occurrence to display which lies in a timeslot before the one given here, the respective timeslot will be displayed above this one as a separate row. +ScheduleWeekTimeFrom: Start of the first timeslot to display in the weekly schedule +ScheduleWeekTimeFromTip: The time of day at which the first timeslot to display in the weekly schedule begins. If there is an occurrence to display which lies in a timeslot before the one given here, the respective timeslot will be displayed above this one as a separate row. ScheduleWeekTimeFromPlaceholder: First timeslot -ScheduleWeekTimeTo: Start (hour) of the last timeslot to display in the weekly schedule -ScheduleWeekTimeToTip: The hour at which the last timeslot to display in the weekly schedule begins. If there is an occurrence to display which lies in a timeslot after the one given here, the respective timeslot will be displayed below this one as a separate row. +ScheduleWeekTimeTo: End of the last timeslot to display in the weekly schedule +ScheduleWeekTimeToTip: The time of day at which the last timeslot to display in the weekly schedule ends. If there is an occurrence to display which lies in a timeslot after the one given here, the respective timeslot will be displayed below this one as a separate row. ScheduleWeekTimeToPlaceholder: Last timeslot -ScheduleWeekTimeslotLength: Length (in hours) of timeslots to display in the weekly schedule -ScheduleWeekTimeslotLengthTip: The length (in hours) of each timeslot to display as a separate row in the weekly schedule +ScheduleWeekTimeslotLength: Length (in minutes) of timeslots to display in the weekly schedule +ScheduleWeekTimeslotLengthTip: The length (in minutes) of each timeslot to display as a separate row in the weekly schedule ScheduleWeekTimeslotLengthPlaceholder: Timeslot length ScheduleWeekTimeFromMustBeAValidTime n@Int: First timeslot to display in the weekly schedule must be between 0 and #{n} diff --git a/models/users.model b/models/users.model index 896262865..502d9faeb 100644 --- a/models/users.model +++ b/models/users.model @@ -28,7 +28,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined - weekStart DayOfWeek default='Monday' -- preferred first day of week for user; user-defined + weekStart DayOfWeek default='monday' -- preferred first day of week for user; user-defined downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this) languages Languages Maybe -- Preferred language; user-defined notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined @@ -36,11 +36,11 @@ User json -- Each Uni2work user has a corresponding row in this table; create csvOptions CsvOptions "default='{}'::jsonb" sex Sex Maybe showSex Bool default=false - scheduleView ScheduleView default='ScheduleViewWeek' + scheduleView ScheduleView default='week' scheduleWeekDays ScheduleWeekDays default='["monday","tuesday","wednesday","thursday","friday"]'::jsonb -- which weekdays to display by default; if there is an occurrence to display for a weekday that is not mentioned here, the weekday will be displayed regardless - scheduleWeekTimeFrom Int default=8 -- starting hour of the first time slot to display in weekly schedule by default (i.e. regardless of the existence of occurrences in this slot); TODO: increase precision to minutes - scheduleWeekTimeTo Int default=18 -- starting hour of the last time slot to display in weekly schedule by default (i.e. regardless of the existence of occurrences in this slot); TODO: increase precision to minutes; TODO: save last hour/minute to display instead of first (of last time slot) - scheduleWeekTimeslotLength Int default=2 -- length of one timeslot in hours; TODO: increase precision to minutes + scheduleWeekTimeFrom NominalDiffTime default=28800 -- start of the first time slot to display in weekly schedule by default (i.e. regardless of the existence of occurrences in this slot) + scheduleWeekTimeTo NominalDiffTime default=72000 -- end of the last time slot to display in weekly schedule by default (i.e. regardless of the existence of occurrences in this slot) + scheduleWeekTimeslotLength NominalDiffTime default=7200 -- length of one timeslot scheduleOccurrenceDisplayDefault Bool default=True -- whether occurrences from new courses should be displayed in the schedule by default UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table UniqueEmail email -- Column 'email' can be used as a row-key in this table diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 2c58b0b5a..254056e55 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -39,9 +39,9 @@ data SettingsForm = SettingsForm , stgDisplayEmail :: UserEmail , stgScheduleView :: ScheduleView , stgScheduleWeekDays :: ScheduleWeekDays - , stgScheduleWeekTimeFrom :: Int - , stgScheduleWeekTimeTo :: Int - , stgScheduleWeekTimeslotLength :: Int + , stgScheduleWeekTimeFrom + , stgScheduleWeekTimeTo :: NominalDiffTime + , stgScheduleWeekTimeslotLength :: NominalDiffTime , stgScheduleOccurrenceDisplayDefault :: Bool , stgMaxFavourites :: Int , stgMaxFavouriteTerms :: Int @@ -108,14 +108,16 @@ makeSettingForm template html = do <*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> template) <*> areq (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template) <* aformSection MsgSchedule - <*> areq (selectField . return $ mkOptionList (scheduleViewList mr)) - (fslI MsgProfileScheduleView & setTooltip MsgProfileScheduleViewTip) { fsId = Just "schedule-view-select" } (stgScheduleView <$> template) + <*> (case universeF of + [sOpt] -> pure sOpt -- Don't bother showing the select as long as there is only one option + _other -> apopt (selectField optionsFinite) (fslI MsgProfileScheduleView & setTooltip MsgProfileScheduleViewTip) { fsId = Just "schedule-view-select" } (stgScheduleView <$> template) + ) <*> scheduleWeekDaysForm (stgScheduleWeekDays <$> template) - <*> areq (natFieldI MsgScheduleWeekTimeFrom) + <*> areq timeOfDayField (fslpI MsgScheduleWeekTimeFrom (mr MsgScheduleWeekTimeFromPlaceholder) & setTooltip MsgScheduleWeekTimeFromTip) (stgScheduleWeekTimeFrom <$> template) - <*> areq (natFieldI MsgScheduleWeekTimeTo ) + <*> areq timeOfDayField (fslpI MsgScheduleWeekTimeTo (mr MsgScheduleWeekTimeToPlaceholder ) & setTooltip MsgScheduleWeekTimeToTip ) (stgScheduleWeekTimeTo <$> template) - <*> areq (natFieldI MsgScheduleWeekTimeslotLength) + <*> areq (convertField (fromInteger . (* 60)) ((`quot` 60) . round) $ posIntFieldI MsgScheduleWeekTimeslotLength) (fslpI MsgScheduleWeekTimeslotLength (mr MsgScheduleWeekTimeslotLengthPlaceholder) & setTooltip MsgScheduleWeekTimeslotLengthTip) (stgScheduleWeekTimeslotLength <$> template) <*> apopt checkBoxField (fslI MsgScheduleOccurrenceDisplayDefault & setTooltip MsgScheduleOccurrenceDisplayDefaultTip) (stgScheduleOccurrenceDisplayDefault <$> template) <* aformSection MsgFormCosmetics @@ -128,7 +130,7 @@ makeSettingForm template html = do <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template) <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template) <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template) - <*> areq (selectField . return $ mkOptionList (weekDayList mr)) (fslI MsgWeekStart) (stgWeekStart <$> template) + <*> areq (selectField optionsFinite) (fslI MsgWeekStart) (stgWeekStart <$> template) <* aformSection MsgFormBehaviour <*> apopt checkBoxField (fslI MsgDownloadFiles & setTooltip MsgDownloadFilesTip @@ -143,31 +145,12 @@ makeSettingForm template html = do <*> allocationNotificationForm (stgAllocationNotificationSettings <$> template) return (result, widget) where - scheduleViewList mr = [ Option (mr t) t (toPathPiece t) | t <- universeF ] themeList = [ Option (toMessage t) t (toPathPiece t) | t <- universeF ] - weekDayList mr = [ Option (mr t) t (toPathPiece t) | t <- universeF ] scheduleWeekDaysForm :: Maybe ScheduleWeekDays -> AForm Handler ScheduleWeekDays -scheduleWeekDaysForm template = formToAForm $ scheduleWeekDaysView =<< renderWForm FormStandard scheduleWeekDaysForm' mempty - where - scheduleWeekDaysForm' :: WForm Handler (FormResult ScheduleWeekDays) - scheduleWeekDaysForm' = do - mr <- getMessageRender - let allWeekDays = universeF - weekDayForm wDay = fmap (ScheduleWeekDays . bool mempty [wDay]) <$> wpopt checkBoxField (fslI $ mr wDay) ((\(ScheduleWeekDays wDays) -> wDay `elem` wDays) <$> template) - fold <$> mapM weekDayForm allWeekDays - - scheduleWeekDaysView :: (FormResult ScheduleWeekDays, Widget) -> MForm Handler (FormResult ScheduleWeekDays, [FieldView UniWorX]) - scheduleWeekDaysView (res, fvInput) = do - mr <- getMessageRender - let fvLabel = toHtml $ mr MsgScheduleWeekDays - fvTooltip = Just . toHtml $ mr MsgScheduleWeekDaysTip - fvRequired = False - fvErrors - | FormFailure (err : _) <- res = Just $ toHtml err - | otherwise = Nothing - fvId <- newIdent - return (res, pure FieldView{..}) +scheduleWeekDaysForm template' = prismAForm (_Wrapped . _IndicatorFunction) template' $ \template + -> let dayForm wDay = apopt checkBoxField (fslI wDay) (template <&> ($ wDay)) + in funcForm dayForm (fslI MsgScheduleWeekDays & setTooltip MsgScheduleWeekDaysTip) False schoolsForm :: Maybe (Set SchoolId) -> AForm Handler (Set SchoolId) schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandard schoolsForm' mempty @@ -364,21 +347,11 @@ validateSettings User{..} = do guardValidation MsgUserDisplayNameInvalid $ validDisplayName userTitle userFirstName userSurname userDisplayName' - userScheduleWeekTimeFrom' <- use _stgScheduleWeekTimeFrom - userScheduleWeekTimeTo' <- use _stgScheduleWeekTimeTo - userScheduleWeekTimeslotLength' <- use _stgScheduleWeekTimeslotLength + userScheduleWeekTimeFrom' <- use _stgScheduleWeekTimeFrom + userScheduleWeekTimeTo' <- use _stgScheduleWeekTimeTo - let maxFrom = 25 - userScheduleWeekTimeslotLength' - guardValidation (MsgScheduleWeekTimeFromMustBeAValidTime maxFrom) - $ 0 < userScheduleWeekTimeFrom' && userScheduleWeekTimeFrom' < maxFrom - guardValidation MsgScheduleWeekTimeToMustBeAValidTime - $ 0 < userScheduleWeekTimeTo' && userScheduleWeekTimeTo' < 25 guardValidation MsgScheduleWeekTimeToMustBeAfterTimeFrom $ userScheduleWeekTimeTo' > userScheduleWeekTimeFrom' - guardValidation MsgScheduleWeekTimeslotLengthMustBeGreaterZero - $ userScheduleWeekTimeslotLength' > 0 - guardValidation MsgScheduleWeekTimeFromToMustMatchTimeslotLength - $ userScheduleWeekTimeTo' `elem` [userScheduleWeekTimeFrom', userScheduleWeekTimeFrom'+userScheduleWeekTimeslotLength' .. 24-userScheduleWeekTimeslotLength'] data ButtonResetTokens = BtnResetTokens diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index a58a39b92..c66febdd1 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1287,7 +1287,7 @@ dayTimeField fs mutc = do fieldTimeFormat :: String -- fieldTimeFormat = "%e.%m.%y %k:%M" -fieldTimeFormat = "%Y-%m-%dT%H:%M:%S" +fieldTimeFormat = "%Y-%m-%dT%H:%M:%S%Q" localTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m LocalTime localTimeField = Field diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index c85065220..ed1dd8f4f 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -992,6 +992,7 @@ customMigrations = Map.fromListWith (>>) ) , ( AppliedMigrationKey [migrationVersion|43.0.0|] [version|44.0.0|] , [executeQQ| + SET client_min_messages TO WARNING; ALTER TABLE IF EXISTS ^{Allocation} ALTER COLUMN @{AllocationDescription} TYPE jsonb USING (CASE WHEN @{AllocationDescription} IS NOT NULL THEN to_json(@{AllocationDescription}) ELSE NULL END); ALTER TABLE IF EXISTS ^{Allocation} ALTER COLUMN @{AllocationStaffDescription} TYPE jsonb USING (CASE WHEN @{AllocationStaffDescription} IS NOT NULL THEN to_json(@{AllocationStaffDescription}) ELSE NULL END); ALTER TABLE IF EXISTS ^{Course} ALTER COLUMN @{CourseDescription} TYPE jsonb USING (CASE WHEN @{CourseDescription} IS NOT NULL THEN to_json(@{CourseDescription}) ELSE NULL END); @@ -1009,6 +1010,7 @@ customMigrations = Map.fromListWith (>>) ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageSummary} IS NOT NULL THEN to_json(@{SystemMessageSummary}) ELSE NULL END); ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationContent} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationContent} IS NOT NULL THEN to_json(@{SystemMessageTranslationContent}) ELSE NULL END); ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationSummary} IS NOT NULL THEN to_json(@{SystemMessageTranslationSummary}) ELSE NULL END); + SET client_min_messages TO NOTICE; |] ) ] diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 16942e98a..39c3ef966 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -21,6 +21,8 @@ import Web.HttpApiData import Data.Aeson.Types as Aeson +import Model.Types.TH.PathPiece + ---- -- Terms, Seaons, anything loosely related to time @@ -189,3 +191,13 @@ derivePersistFieldJSON ''Occurrences nullaryPathPiece ''DayOfWeek camelToPathPiece +derivePersistFieldPathPiece ''DayOfWeek + + +newtype ScheduleWeekDays = ScheduleWeekDays (Set DayOfWeek) + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (Semigroup, Monoid) + +deriveJSON defaultOptions ''ScheduleWeekDays +derivePersistFieldJSON ''ScheduleWeekDays +makeWrapped ''ScheduleWeekDays diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index 92db27b6a..7eee837b9 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -28,7 +28,6 @@ import qualified Data.Aeson as JSON import Database.Persist.Sql (PersistFieldSql(..)) import Utils.Lens.TH -import Utils.Schedule.Types.ScheduleView import Web.HttpApiData @@ -281,22 +280,3 @@ instance ToHttpApiData TokenBucketIdent where toUrlPiece = toPathPiece instance FromHttpApiData TokenBucketIdent where parseUrlPiece = maybe (Left "Could not parse TokenBucketIdent") Right . fromPathPiece - - -derivePersistField "DayOfWeek" - -newtype ScheduleWeekDays = ScheduleWeekDays [DayOfWeek] - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -instance Semigroup ScheduleWeekDays where - ScheduleWeekDays w <> ScheduleWeekDays w' = ScheduleWeekDays $ w <> w' -instance Monoid ScheduleWeekDays where - mempty = ScheduleWeekDays mempty - -deriveJSON defaultOptions ''ScheduleWeekDays -derivePersistFieldJSON ''ScheduleWeekDays - - -pathPieceJSON ''ScheduleView -pathPieceJSONKey ''ScheduleView -derivePersistField "ScheduleView" diff --git a/src/Settings.hs b/src/Settings.hs index e278b2459..240baec00 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -218,8 +218,8 @@ data UserDefaultConf = UserDefaultConf , userDefaultShowSex :: Bool , userDefaultScheduleView :: ScheduleView , userDefaultScheduleWeekDays :: ScheduleWeekDays - , userDefaultScheduleWeekTimeFrom, userDefaultScheduleWeekTimeTo :: Int - , userDefaultScheduleWeekTimeslotLength :: Int + , userDefaultScheduleWeekTimeFrom, userDefaultScheduleWeekTimeTo :: NominalDiffTime + , userDefaultScheduleWeekTimeslotLength :: NominalDiffTime , userDefaultScheduleOccurrenceDisplayDefault :: Bool } deriving (Show) diff --git a/src/Utils.hs b/src/Utils.hs index 9b6b03e4c..b76e5a31d 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -526,6 +526,21 @@ setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (previ setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k setFromFunc = Set.fromList . flip filter universeF +funcFromSet :: Ord k => Set k -> (k -> Bool) +funcFromSet = flip Set.member + +_IndicatorFunction :: (Finite k, Ord k) => Iso' (Set k) (k -> Bool) +_IndicatorFunction = iso funcFromSet setFromFunc + +setFromMap :: Map k Bool -> Set k +setFromMap = Map.keysSet . Map.filter id + +mapFromSet :: Set k -> Map k Bool +mapFromSet = Map.fromSet $ const True + +_IndicatorMap :: Iso' (Set k) (Map k Bool) +_IndicatorMap = iso mapFromSet setFromMap + ---------- -- Maps -- ---------- diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index 0ef6ca5a0..def183422 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -11,6 +11,7 @@ module Utils.DateTime , mkDateTimeFormatter , nominalHour, nominalMinute , minNominalYear, avgNominalYear + , nominalTimeToTimeOfDay, timeOfDayToNominalTime , module Zones , day ) where @@ -24,6 +25,7 @@ import Data.Time.Zones.TH as Zones (includeSystemTZ) import Data.Time.Zones (localTimeToUTCTZ, timeZoneForUTCTime) import Data.Time.Format (FormatTime) import Data.Time.Clock.System (systemEpochDay) +import Data.Time.LocalTime (timeToTimeOfDay, timeOfDayToTime) import qualified Data.Time.Format.ISO8601 as Time import qualified Data.Time.Format as Time @@ -148,6 +150,11 @@ minNominalYear, avgNominalYear :: NominalDiffTime minNominalYear = 365 * nominalDay avgNominalYear = fromRational $ 365.2425 * toRational nominalDay +nominalTimeToTimeOfDay :: NominalDiffTime -> TimeOfDay +nominalTimeToTimeOfDay = timeToTimeOfDay . realToFrac +timeOfDayToNominalTime :: TimeOfDay -> NominalDiffTime +timeOfDayToNominalTime = realToFrac . timeOfDayToTime + --------- -- Day -- --------- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 99b779905..6f7aa5057 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -664,6 +664,28 @@ daysField = convertField fromDays toDays fractionalField toDays = (/ nominalDay) fromDays = (* nominalDay) +timeOfDayField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m NominalDiffTime +timeOfDayField = Field{..} + where + precision :: Pico + precision = MkFixed 1 + timeFormat :: String + timeFormat = "%H:%M:%S%Q" + + fieldEnctype = UrlEncoded + fieldView theId name attrs val' isReq + = [whamlet| + $newline never + + |] + where val :: Text + val = either id (pack . formatTime defaultTimeLocale timeFormat . nominalTimeToTimeOfDay) val' + fieldParse = parseHelper $ \t + -> case parseTimeM True defaultTimeLocale timeFormat (T.unpack t) of + Just tod -> Right $ timeOfDayToNominalTime tod + Nothing -> Left MsgInvalidTimeFormat + + data SecretJSONFieldException = SecretJSONFieldDecryptFailure deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) @@ -1081,7 +1103,7 @@ hoistField f Field{..} = Field } prismAForm :: Monad m => Prism' s a -> Maybe s -> (Maybe a -> AForm m a) -> AForm m s --- ^ @Monad m => Prism' s a -> (Maybe a -> AForm m a) -> (Maybe s -> AForm m s)@ +-- ^ TODO: @Monad m => Prism' s a -> (Maybe a -> AForm m a) -> (Maybe s -> AForm m s)@ prismAForm p outer form = review p <$> form inner where inner = outer >>= preview p diff --git a/src/Utils/Schedule/Types/ScheduleView.hs b/src/Utils/Schedule/Types/ScheduleView.hs index 818a0b385..c6af88fc4 100644 --- a/src/Utils/Schedule/Types/ScheduleView.hs +++ b/src/Utils/Schedule/Types/ScheduleView.hs @@ -4,6 +4,8 @@ module Utils.Schedule.Types.ScheduleView import Import.NoModel +import Model.Types.TH.PathPiece + data ScheduleView = ScheduleViewWeek deriving (Eq, Ord, Enum, Show, Read, Generic, Typeable) @@ -14,4 +16,7 @@ instance Bounded ScheduleView where instance Finite ScheduleView instance Universe ScheduleView -derivePathPiece ''ScheduleView (camelToPathPiece' 1) "_" +nullaryPathPiece ''ScheduleView $ camelToPathPiece' 2 +pathPieceJSON ''ScheduleView +pathPieceJSONKey ''ScheduleView +derivePersistFieldPathPiece ''ScheduleView diff --git a/src/Utils/Schedule/Week.hs b/src/Utils/Schedule/Week.hs index fd4c2631e..c4d12f9a5 100644 --- a/src/Utils/Schedule/Week.hs +++ b/src/Utils/Schedule/Week.hs @@ -21,7 +21,6 @@ import Utils.Schedule.Week.TimeSlot weekSchedule :: Entity User -> ScheduleOffset -> Widget weekSchedule (Entity uid User{userScheduleWeekDays=ScheduleWeekDays userScheduleWeekDays,..}) scheduleOffset = do now <- liftIO getCurrentTime - tz <- liftIO getCurrentTimeZone ata <- getSessionActiveAuthTags let @@ -86,7 +85,7 @@ weekSchedule (Entity uid User{userScheduleWeekDays=ScheduleWeekDays userSchedule ( d , Map.fromList $ allTimeSlots <&> \slot -> ( slot - , filter (seIsInSlot tz d slot) scheduleEntries + , filter (seIsInSlot d slot) scheduleEntries ) ) where scheduleEntries = join $ (courseEventToScheduleEntries <$> courseEvents) @@ -129,7 +128,7 @@ weekSchedule (Entity uid User{userScheduleWeekDays=ScheduleWeekDays userSchedule timeSlotsDefaultDisplay = Set.fromList $ timeSlotsFromTo userScheduleWeekTimeslotLength userScheduleWeekTimeFrom userScheduleWeekTimeTo allTimeSlots :: [TimeSlot] - allTimeSlots = timeSlotsFromTo userScheduleWeekTimeslotLength 0 (24 - userScheduleWeekTimeslotLength) + allTimeSlots = timeSlotsAll userScheduleWeekTimeslotLength userScheduleWeekTimeFrom timeSlotIsEmpty :: TimeSlot -> Bool timeSlotIsEmpty slot = foldr (\d acc -> acc && maybe True null (d Map.!? slot)) True events @@ -140,8 +139,8 @@ weekSchedule (Entity uid User{userScheduleWeekDays=ScheduleWeekDays userSchedule -- Local helper functions -- | Check whether a given ScheduleEntry lies in a given TimeSlot -seIsInSlot :: TimeZone -> Day -> TimeSlot -> ScheduleEntry -> Bool -seIsInSlot tz d slot = +seIsInSlot :: Day -> TimeSlot -> ScheduleEntry -> Bool +seIsInSlot d slot = let occurrenceIsInSlot occurrence = occDay == d && occTime `isInTimeSlot` slot where (occDay, occTime) = case occurrence of Right ScheduleWeekly{..} -> (scheduleDayOfWeek `dayOfWeekToDayWith` d, scheduleStart) @@ -150,7 +149,7 @@ seIsInSlot tz d slot = in \case ScheduleCourseEvent{sceOccurrence} -> occurrenceIsInSlot sceOccurrence ScheduleTutorial{stOccurrence} -> occurrenceIsInSlot stOccurrence - ScheduleExamOccurrence{seoStart} -> let (slotTime,nextSlotTime) = timeSlotToUTCTime tz d slot + ScheduleExamOccurrence{seoStart} -> let (slotTime,nextSlotTime) = timeSlotToUTCTime d slot in slotTime <= seoStart && seoStart < nextSlotTime diff --git a/src/Utils/Schedule/Week/TimeSlot.hs b/src/Utils/Schedule/Week/TimeSlot.hs index 91710bfce..41c3f1b45 100644 --- a/src/Utils/Schedule/Week/TimeSlot.hs +++ b/src/Utils/Schedule/Week/TimeSlot.hs @@ -1,7 +1,6 @@ module Utils.Schedule.Week.TimeSlot ( TimeSlot(..) - , timeSlot - , timeSlotsFromTo + , timeSlots, timeSlotsFromTo, timeSlotsAll , isInTimeSlot , nextTimeSlot , timeSlotToUTCTime @@ -10,7 +9,7 @@ module Utils.Schedule.Week.TimeSlot import Import -import Handler.Utils.DateTime (formatTimeRangeW) +import Handler.Utils.DateTime (formatTimeRangeW, localTimeToUTCSimple) import Utils.Schedule.Week.Types.TimeSlot @@ -18,38 +17,51 @@ import Utils.Schedule.Week.Types.TimeSlot -- TODO: This module needs major refactoring --- TODO: remove (deprecated; now in user settings) --- slotStep :: Int --- slotStep = 2 +timeSlots :: Bool -- ^ Only slots between from/to? + -> NominalDiffTime -- ^ Step + -> NominalDiffTime -- ^ From + -> NominalDiffTime -- ^ To + -> [TimeSlot] +timeSlots onlyFromTo (abs -> slotStep) f t + | t < f = timeSlots onlyFromTo slotStep t f + | slotStep <= 0 = error "Invalid slotStep" + | otherwise = reverse [ TimeSlot{..} + | tsTo <- [f,f - slotStep..0] + , let tsFrom = tsTo - slotStep + , not onlyFromTo || tsFrom >= f + , tsFrom >= 0 + ] + ++ [ TimeSlot{..} + | tsFrom <- [f,f + slotStep..nominalDay] + , let tsTo = tsFrom + slotStep + , not onlyFromTo || tsTo <= t + , tsTo <= nominalDay + ] +timeSlotsFromTo :: NominalDiffTime -- ^ Step + -> NominalDiffTime -- ^ From + -> NominalDiffTime -- ^ To + -> [TimeSlot] +timeSlotsFromTo = timeSlots True -timeSlot :: Int -> Int -> TimeSlot -timeSlot slotStep h = TimeSlot{..} where - tsFrom = TimeOfDay h 0 0 - tsTo = TimeOfDay (h+slotStep) 0 0 - - --- | Get TimeSlots from a given start TimeOfDay to a given end TimeOfDay -timeSlotsFromTo :: Int -> Int -> Int -> [TimeSlot] -timeSlotsFromTo slotStep f t = (timeSlot slotStep) <$> [f,f+slotStep..t] +timeSlotsAll :: NominalDiffTime -- ^ Step + -> NominalDiffTime -- ^ From + -> [TimeSlot] +timeSlotsAll step f = timeSlots False step f f -- @t@ is unused in `timeSlots`, iff @onlyFromTo@ is `False` -- | Check whether a given time of day lies within a given TimeSlot isInTimeSlot :: TimeOfDay -> TimeSlot -> Bool -isInTimeSlot time TimeSlot{..} = tsFrom <= time && time < tsTo +isInTimeSlot (timeOfDayToNominalTime -> time) TimeSlot{..} = tsFrom <= time && time < tsTo -- | Get the successor of a TimeSlot -nextTimeSlot :: Int -> TimeSlot -> TimeSlot -nextTimeSlot slotStep TimeSlot{tsTo=tsFrom} = let tsTo = TimeOfDay (todHour tsFrom + slotStep) 0 0 in TimeSlot{..} +nextTimeSlot :: NominalDiffTime -> TimeSlot -> TimeSlot +nextTimeSlot slotStep TimeSlot{..} = TimeSlot{ tsFrom = tsTo, tsTo = tsTo + slotStep } -- | Convert a TimeSlot to UTCTime for a given TimeZone -timeSlotToUTCTime :: TimeZone -> Day -> TimeSlot -> (UTCTime, UTCTime) -timeSlotToUTCTime tz d TimeSlot{..} = (timeOfDayToUTC tsFrom, timeOfDayToUTC tsTo) where - timeOfDayToUTC time = - let (slotDayOffset, slotTimeOfDay) = localToUTCTimeOfDay tz time - utctDay = slotDayOffset `addDays` d - utctDayTime = timeOfDayToTime slotTimeOfDay - in UTCTime{..} +timeSlotToUTCTime :: Day -> TimeSlot -> (UTCTime, UTCTime) +timeSlotToUTCTime d TimeSlot{..} = (timeOfDayToUTC tsFrom, timeOfDayToUTC tsTo) + where timeOfDayToUTC = localTimeToUTCSimple . LocalTime d . nominalTimeToTimeOfDay -- | Format a given TimeSlot as time range formatTimeSlotW :: TimeSlot -> Widget -formatTimeSlotW TimeSlot{..} = formatTimeRangeW SelFormatTime tsFrom $ Just tsTo +formatTimeSlotW TimeSlot{..} = formatTimeRangeW SelFormatTime (nominalTimeToTimeOfDay tsFrom) $ Just (nominalTimeToTimeOfDay tsTo) diff --git a/src/Utils/Schedule/Week/Types/TimeSlot.hs b/src/Utils/Schedule/Week/Types/TimeSlot.hs index 869099903..32b815eba 100644 --- a/src/Utils/Schedule/Week/Types/TimeSlot.hs +++ b/src/Utils/Schedule/Week/Types/TimeSlot.hs @@ -5,8 +5,10 @@ module Utils.Schedule.Week.Types.TimeSlot import Import.NoModel +-- | Half-open interval of time +-- +-- Fields are to be interpreted as time since midnight data TimeSlot = TimeSlot - { tsFrom :: TimeOfDay - , tsTo :: TimeOfDay -- end excluded - } - deriving (Eq, Ord, Show, Read, Generic, Typeable) + { tsFrom :: NominalDiffTime -- ^ Inclusive + , tsTo :: NominalDiffTime -- ^ Exclusive + } deriving (Eq, Ord, Show, Generic, Typeable) diff --git a/templates/schedule/options.hamlet b/templates/schedule/options.hamlet index 71f29de9d..13f3547cb 100644 --- a/templates/schedule/options.hamlet +++ b/templates/schedule/options.hamlet @@ -2,8 +2,9 @@ $newline never #{csrf} -$forall vWgt <- viewWidgets - ^{fvWidget vWgt} +$if length viewWidgets > 1 + $forall vWgt <- viewWidgets + ^{fvWidget vWgt} $forall oWgt <- offsetWidgets ^{fvWidget oWgt} diff --git a/templates/schedule/week.hamlet b/templates/schedule/week.hamlet index 2f8b5ddd4..1de8cff2e 100644 --- a/templates/schedule/week.hamlet +++ b/templates/schedule/week.hamlet @@ -13,7 +13,7 @@ $newline never $forall slot <- allTimeSlots $if Set.member slot timeSlotsDefaultDisplay || not (timeSlotIsEmpty slot) - + ^{formatTimeSlotW slot} $forall day <- week $maybe dayEvents <- Map.lookup day events