diff --git a/messages/de.msg b/messages/de.msg index 4188502e7..72239ce44 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -198,7 +198,9 @@ AdminFor: Administrator LecturerFor: Dozent UserListTitle: Komprehensive Benutzerliste -DateTimeFormatOption dateTimeExp@String dateExp@String timeExp@String: #{dateTimeExp} / #{dateExp} / #{timeExp} +DateTimeFormat: Datums- und Uhrzeitformat +DateFormat: Datumsformat +TimeFormat: Uhrzeitformat InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] Format erwartet AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC konvertieren diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 8a516562c..c5d92dc48 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -22,6 +22,9 @@ import Database.Esqueleto ((^.)) data SettingsForm = SettingsForm { stgMaxFavourties :: Int , stgTheme :: Theme + , stgDateTime :: DateTimeFormat + , stgDate :: DateTimeFormat + , stgTime :: DateTimeFormat } makeSettingForm :: Maybe SettingsForm -> Form SettingsForm @@ -32,6 +35,9 @@ makeSettingForm template = identForm FIDsettings $ \html -> do (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template) <*> areq (selectFieldList themeList) (fslpI MsgTheme "theme-select" ) (stgTheme <$> template) -- TODO: pass theme-select as id-attribute or similar. + <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template) + <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template) + <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template) <* submitButton return (result, widget) -- no validation required here @@ -43,13 +49,19 @@ getProfileR = do let settingsTemplate = Just $ SettingsForm { stgMaxFavourties = userMaxFavourites , stgTheme = userTheme + , stgDateTime = userDateTimeFormat + , stgDate = userDateFormat + , stgTime = userTimeFormat } ((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate case res of (FormSuccess SettingsForm{..}) -> do runDB $ do - update uid [ UserMaxFavourites =. stgMaxFavourties - , UserTheme =. stgTheme + update uid [ UserMaxFavourites =. stgMaxFavourties + , UserTheme =. stgTheme + , UserDateTimeFormat =. stgDateTime + , UserDateFormat =. stgDate + , UserTimeFormat =. stgTime ] when (stgMaxFavourties < userMaxFavourites) $ do -- prune Favourites to user-defined size diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index aa33587ee..ced936b06 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -31,9 +31,6 @@ utcToLocalTime = TZ.utcToLocalTimeTZ appTZ localTimeToUTC :: LocalTime -> LocalToUTCResult localTimeToUTC = TZ.localTimeToUTCFull appTZ -formatTime' :: (FormatTime t, MonadHandler m, HandlerSite m ~ UniWorX) => String -> t -> m Text -formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure t - class FormatTime t => HasLocalTime t where toLocalTime :: t -> LocalTime @@ -46,10 +43,13 @@ instance HasLocalTime Day where instance HasLocalTime UTCTime where toLocalTime t = utcToLocalTime t +formatTime' :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => String -> t -> m Text +formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (toLocalTime t) + -- formatTime :: (FormatTime t, MonadHandler m, HandlerSite m ~ UniWorX, IsString str) => (DateTimeFormat -> String) -> t -> m str -- Restricted type for safety formatTime :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> t -> m Text -formatTime proj t = flip formatTime' (toLocalTime t) =<< (unDateTimeFormat <$> getDateTimeFormat proj) +formatTime proj t = flip formatTime' t =<< (unDateTimeFormat <$> getDateTimeFormat proj) getTimeLocale :: (MonadHandler m, HandlerSite m ~ UniWorX) => m TimeLocale getTimeLocale = getTimeLocale' <$> languages @@ -76,9 +76,13 @@ validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat -- ^ We use a whitelist instead of just letting the user specify their own format string since vulnerabilities in printf-like functions are not uncommon validDateTimeFormats _ SelFormatDateTime = Set.fromList $ [ DateTimeFormat "%a %d %b %Y %R" + , DateTimeFormat "%a %b %d %Y %R" , DateTimeFormat "%A, %d %B %Y %R" + , DateTimeFormat "%A, %B %d %Y %R" , DateTimeFormat "%a %d %b %Y %T" + , DateTimeFormat "%a %b %d %Y %T" , DateTimeFormat "%A, %d %B %Y %T" + , DateTimeFormat "%A, %B %d %Y %T" , DateTimeFormat "%d.%m.%Y %R" , DateTimeFormat "%d.%m.%Y %T" , DateTimeFormat "%R %d.%m.%Y" @@ -89,7 +93,9 @@ validDateTimeFormats _ SelFormatDateTime = Set.fromList $ ] validDateTimeFormats _ SelFormatDate = Set.fromList $ [ DateTimeFormat "%a %d %b %Y" + , DateTimeFormat "%a %b %d %Y" , DateTimeFormat "%A, %d %B %Y" + , DateTimeFormat "%A, %B %d %Y" , DateTimeFormat "%d.%m.%Y" , DateTimeFormat "%Y-%m-%d" ] diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index e16be54d4..4c549109a 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -405,15 +405,16 @@ dayTimeField fs mutc = do -} -utcTimeField :: (Monad m, RenderMessage (HandlerSite m) FormMessage, RenderMessage (HandlerSite m) UniWorXMessage) => Field m UTCTime +utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime -- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing) -- Browser returns LocalTime utcTimeField = Field { fieldParse = parseHelperGen $ readTime - , fieldView = \theId name attrs val isReq -> + , fieldView = \theId name attrs val isReq -> do + val' <- either id id <$> traverse (formatTime' fieldTimeFormat) val [whamlet| $newline never - + |] , fieldEnctype = UrlEncoded } @@ -431,9 +432,6 @@ utcTimeField = Field (Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime Nothing -> Left MsgInvalidDateTimeFormat - showTime :: UTCTime -> Text - showTime = fromString . (Time.formatTime defaultTimeLocale fieldTimeFormat) - fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED fsm = bfs -- TODO: get rid of Bootstrap