Merge branch 'master' into 'live'

Deploy time format customization

See merge request !51

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

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
+          update uid  [ UserMaxFavourites  =. stgMaxFavourties
-                      , UserTheme         =. stgTheme
+                      , UserTheme          =. stgTheme
+                      , UserDateTimeFormat =. stgDateTime
+                      , UserDateFormat     =. stgDate
+                      , UserTimeFormat     =. stgTime
                       ]
           when (stgMaxFavourties < userMaxFavourites) $ do
             -- prune Favourites to user-defined size

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"
   ]

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
-          <input id="#{theId}" name="#{name}" *{attrs} type="datetime-local" :isReq:required value="#{either id showTime val}">
+          <input id="#{theId}" name="#{name}" *{attrs} type="datetime-local" :isReq:required value="#{val'}">
         |]
     , 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