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