Merge branch 'feat/timezones' into 'staging'

Timezones, date formatting & minor cleanup

See merge request !45

config/settings.yml

@@ -40,7 +40,12 @@ ldap:
   password: "_env:LDAPPW:"
   basename: "_env:LDAPBN:"
 
-userDefaultFavourites: 12
+default-favourites: 12
+default-theme: Default
+default-date-time-format:
+  dateTimeFormat: "%a %d %b %Y %R"
+  dateFormat: "%d.%m.%Y"
+  timeFormat: "%R"
 
 cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf"
 

db.hs

@@ -47,7 +47,7 @@ main = do
 
 fillDb :: DB ()
 fillDb = do
-  defaultFavourites <- getsYesod $ appDefaultFavourites . appSettings
+  defaultFavourites <- getsYesod $ appDefaultMaxFavourites . appSettings
   now <- liftIO getCurrentTime
   let
     summer2017 = TermIdentifier 2017 Summer
@@ -60,7 +60,8 @@ fillDb = do
     , userEmail  = "G.Kleen@campus.lmu.de"
     , userDisplayName = "Gregor Kleen"
     , userMaxFavourites = 6
-    , userTheme = AberdeenReds
+    , userTheme = Default
+    , userDateTimeFormat = def
     }
   fhamann <- insert User
     { userPlugin = "LDAP"
@@ -70,6 +71,7 @@ fillDb = do
     , userDisplayName = "Felix Hamann"
     , userMaxFavourites = defaultFavourites
     , userTheme = Default
+    , userDateTimeFormat = def
     }
   jost <- insert User
     { userPlugin = "LDAP"
@@ -79,6 +81,7 @@ fillDb = do
     , userDisplayName = "Steffen Jost"
     , userMaxFavourites = 14
     , userTheme = MossGreen
+    , userDateTimeFormat = def
     }
   void . insert $ User
     { userPlugin = "LDAP"
@@ -88,6 +91,7 @@ fillDb = do
     , userDisplayName = "Max Musterstudent"
     , userMaxFavourites = 7
     , userTheme = AberdeenReds
+    , userDateTimeFormat = def
     }
   void . insert $ Term
     { termName     = summer2017

messages/de.msg

@@ -76,6 +76,7 @@ CorrectionHead tid@TermId courseShortHand@Text sheetName@Text cid@CryptoFileName
 SubmissionMember g@Int: Mitabgebende(r) ##{display g}
 SubmissionArchive: Zip-Archiv der Abgabedatei(en)
 SubmissionFile: Datei zur Abgabe
+SubmissionFiles: Abgegebene Dateien
 SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem bÜbungsblatt.
 
 CorrectionsTitle: Zugewiesene Korrekturen
@@ -195,4 +196,12 @@ NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
 
 AdminFor: Administrator
 LecturerFor: Dozent
-UserListTitle: Komprehensive Benutzerliste
+UserListTitle: Komprehensive Benutzerliste
+
+DateTimeFormatOption dateTimeExp@String dateExp@String timeExp@String: #{dateTimeExp} / #{dateExp} / #{timeExp}
+
+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
+
+LastEdits: Letzte Änderungen
+EditedBy name@Text time@Text: Durch #{name} um #{time}

models

@@ -4,8 +4,9 @@ User json
     matrikelnummer Text Maybe
     email          Text
     displayName    Text
-    maxFavourites  Int   default=12
+    maxFavourites  Int
-    theme          Theme default='default'
+    theme          Theme
+    dateTimeFormat DateTimeFormat
     UniqueAuthentication plugin ident
     UniqueEmail email
     deriving Show
@@ -67,7 +68,7 @@ Course
     registerTo       UTCTime Maybe
     deregisterUntil  UTCTime Maybe
     registerSecret   Text Maybe        -- Falls ein Passwort erforderlich ist
-    materialFree     Bool default=true
+    materialFree     Bool
     CourseTermShort  term shorthand
 CourseEdit
     user         UserId

package.yaml

@@ -83,6 +83,9 @@ dependencies:
 - MonadRandom
 - email-validate
 - scientific
+- tz
+- system-locale
+- th-lift-instances
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Foundation.hs

@@ -72,8 +72,8 @@ import System.FilePath
 
 import Handler.Utils.Templates
 import Handler.Utils.StudyFeatures
-import Handler.Utils.DateTime
 import Control.Lens
+import Utils
 import Utils.Lens
 
 import Data.Aeson
@@ -88,9 +88,6 @@ import Text.Shakespeare.Text (st)
 instance DisplayAble TermId where
   display = termToText . unTermKey
 
-instance DisplayAble UTCTime where
-  display = pack . formatTimeGerDT2 -- default Time Format to be used: 00.00.00 00:00
-
 instance (PathPiece b) => DisplayAble (Data.CryptoID.CryptoID a b) where
   display = toPathPiece -- requires import of Data.CryptoID here
 -- -- MOVE ABOVE
@@ -184,6 +181,13 @@ instance RenderMessage UniWorX SheetFileType where
       SheetMarking  -> renderMessage' MsgSheetMarking
     where renderMessage' = renderMessage foundation ls
 
+getTimeLocale' :: [Lang] -> TimeLocale
+getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")])
+
+appTZ :: TZ
+appTZ = $(includeSystemTZ "Europe/Berlin")
+
+  
 -- Access Control
 data AccessPredicate
   = APPure     (Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
@@ -999,9 +1003,12 @@ instance YesodAuth UniWorX where
       userEmail <- maybe (throwError $ ServerError "Could not retrieve user email") return userEmail'
       userDisplayName <- maybe (throwError $ ServerError "Could not retrieve user name") return userDisplayName'
 
+      AppSettings{..} <- getsYesod appSettings
+
       let
-        userMaxFavourites = 12 -- TODO: appDefaultFavourites appSettings
+        userMaxFavourites = appDefaultMaxFavourites
-        userTheme = Default    -- TODO: appDefaultFavourites appSettings
+        userTheme = appDefaultTheme
+        userDateTimeFormat = appDefaultDateTimeFormat
         newUser = User{..}
         userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
                      , UserDisplayName =. userDisplayName

src/Handler/Course.hs

@@ -62,8 +62,8 @@ getTermCourseListR tid = do
         [ sortable (Just "shorthand") (textCell MsgCourse) $ anchorCell'
             (\(Entity _ Course{..}, _) -> CourseR courseTerm courseShorthand CShowR)
             (\(Entity _ Course{..}, _) -> toWidget courseShorthand)
-        , sortable (Just "register-from") (textCell MsgRegisterFrom) $ \(Entity _ Course{..}, _) -> textCell $ display courseRegisterFrom
+        , sortable (Just "register-from") (textCell MsgRegisterFrom) $ \(Entity _ Course{..}, _) -> cell $ traverse (formatTime dateTimeFormat) courseRegisterFrom >>= maybe mempty toWidget
-        , sortable (Just "register-to") (textCell MsgRegisterTo) $ \(Entity _ Course{..}, _) -> textCell $ display courseRegisterTo
+        , sortable (Just "register-to") (textCell MsgRegisterTo) $ \(Entity _ Course{..}, _) -> cell $ traverse (formatTime dateTimeFormat) courseRegisterTo >>= maybe mempty toWidget
         , sortable (Just "members") (textCell MsgCourseMembers) $ \(Entity _ Course{..}, E.Value num) -> textCell $ case courseCapacity of
             Nothing -> MsgCourseMembersCount num
             Just max -> MsgCourseMembersCountLimited num max
@@ -110,6 +110,8 @@ getCShowR tid csh = do
   let course = entityVal courseEnt
   (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
   registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid csh CRegisterR) True
+  mRegFrom <- traverse (formatTime dateTimeFormat) $ courseRegisterFrom course
+  mRegTo   <- traverse (formatTime dateTimeFormat) $ courseRegisterTo course
   defaultLayout $ do
     setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|]
     $(widgetFile "course")

src/Handler/Home.hs

@@ -16,7 +16,7 @@ import Handler.Utils
 
 import qualified Data.Map as Map
 
-import Data.Time
+import Data.Time hiding (formatTime)
 -- import qualified Data.Text as T
 -- import Yesod.Form.Bootstrap3
 
@@ -77,7 +77,7 @@ homeAnonymous = do
         , sortable (Just "term")  (textCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
             textCell $ display $ courseTerm course
         , sortable (Just "deadline") (textCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
-            textCell $ display $ courseRegisterTo course
+            cell $ traverse (formatTime dateTimeFormat) (courseRegisterTo course) >>= maybe mempty toWidget
         ]
   courseTable <- dbTable def $ DBTable
     { dbtSQLQuery  = tableData
@@ -154,7 +154,7 @@ homeUser uid = do
         , sortable (Just "sheet")  (textCell MsgSheet)  $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, _) } ->
             cell [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{display shn}|]
         , sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline, _) } ->
-            textCell $ display deadline
+            cell $ formatTime dateTimeFormat deadline >>= toWidget
         , sortable (Just "done")   (textCell MsgDone)   $ \(DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, E.Value mbsid) }) ->
             case mbsid of
               Nothing    -> mempty

src/Handler/Sheet.hs

@@ -160,8 +160,8 @@ getSheetListR tid csh = do
   let tid = courseTerm course
   let colBase = mconcat
         [ headed "Blatt"       $ \(sid,sheet,_) -> simpleLink (toWgt $ sheetName sheet) $ CSheetR tid csh (sheetName sheet) SShowR
-        , headed "Abgabe ab"   $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
+        , headed "Abgabe ab"   $ \(_,Sheet{..},_) -> formatTime dateTimeFormat sheetActiveFrom >>= toWidget
-        , headed "Abgabe bis"  $ toWgt . formatTimeGerWD . sheetActiveTo   . snd3
+        , headed "Abgabe bis"  $ \(_,Sheet{..},_) -> formatTime dateTimeFormat sheetActiveTo >>= toWidget
         , headed "Bewertung"   $ toWgt . display . sheetType . snd3
         ]
   let colAdmin = mconcat -- only show edit button for allowed course assistants
@@ -222,7 +222,7 @@ getSShowR tid csh shn = do
               SheetExercise -> textCell $ display $ sheetActiveFrom   sheet
               SheetHint     -> textCell $ display $ sheetHintFrom     sheet
               SheetSolution -> textCell $ display $ sheetSolutionFrom sheet
-        , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT (modified :: UTCTime)
+        , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime dateTimeFormat (modified :: UTCTime) >>= toWidget
         ]
   fileTable <- dbTable def $ DBTable
     { dbtSQLQuery = fileData
@@ -244,8 +244,9 @@ getSShowR tid csh shn = do
     }
   defaultLayout $ do
     setTitle $ toHtml $ T.append "Übung " $ sheetName sheet
+    sheetFrom <- formatTime dateTimeFormat $ sheetActiveFrom sheet
+    sheetTo <- formatTime dateTimeFormat $ sheetActiveTo sheet
     $(widgetFile "sheetShow")
-    [whamlet| Under Construction !!! |] -- TODO
 
 getSFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
 getSFileR tid csh shn typ title = do

src/Handler/Submission.hs

@@ -160,7 +160,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
             E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
             E.limit numberOfSubmissionEditDates
             return $ (user E.^. UserDisplayName, submissionEdit E.^. SubmissionEditTime)
-        let lastEdits = map (bimap E.unValue E.unValue) lastEditValues
+        lastEdits <- forM lastEditValues $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime dateTimeFormat time
         return (sheet,buddies,lastEdits)
   let unpackZips = True -- undefined -- TODO
   ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping $ map E.unValue buddies

src/Handler/Term.hs

@@ -46,19 +46,25 @@ getTermShowR = do
                 anchorCell' (\(Entity tid _, _) -> TermCourseListR tid)
                             (\(Entity tid _, _) -> [whamlet|#{display tid}|])
             , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) ->
-                stringCell $ formatTimeGerWD termLectureStart
+                cell $ formatTime dateFormat termLectureStart >>= toWidget
             , sortable (Just "lecture-end") "Ende Vorlesungen"   $ \(Entity _ Term{..},_) ->
-                stringCell $ formatTimeGerWD termLectureEnd
+                cell $ formatTime dateFormat termLectureEnd >>= toWidget
             , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
                 textCell $ (bool "" tickmark termActive :: Text)
             , sortable Nothing "Kurse" $ \(_, E.Value numCourses) ->
                 cell [whamlet|_{MsgNumCourses numCourses}|]
             , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
-                stringCell $ formatTimeGerWD termStart
+                cell $ formatTime dateFormat termStart >>= toWidget
             , sortable (Just "end") "Semesterende"   $ \(Entity _ Term{..},_) ->
-                stringCell $ formatTimeGerWD termEnd
+                cell $ formatTime dateFormat termEnd >>= toWidget
             , sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
-                stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays
+                cell $ do
+                  termHolidays' <- mapM (formatTime dateFormat) termHolidays
+                  [whamlet|
+                    <ul .list--inline .list--comma-separated>
+                      $forall holiday <- termHolidays'
+                        <li>#{holiday}
+                  |]
             ]
 --       let adminColonnade =
 --           [ sortable Nothing "Edit" $ \(Entity tid Term{..},_) -> cell $ do

src/Handler/Utils/DateTime.hs

@@ -1,60 +1,87 @@
-module Handler.Utils.DateTime where
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+           , OverloadedStrings
+           , RecordWildCards
+           , TypeFamilies
+  #-}
 
-import Data.Time
+module Handler.Utils.DateTime
+  ( utcToLocalTime
+  , localTimeToUTC, TZ.LocalToUTCResult(..)
+  , formatTime'
+  , formatTime
+  , getTimeLocale, getDateTimeFormat
+  , validDateTimeFormats, dateTimeFormatOptions
+  ) where
 
+import Import
 
-germanTimeLocale :: TimeLocale 
+import Data.Time.Zones hiding (localTimeToUTCFull)
-germanTimeLocale = TimeLocale 
+import qualified Data.Time.Zones as TZ
-  { wDays   = [("Sonntag"    ,"So")
-              ,("Montag"     ,"Mo")
-              ,("Dienstag"   ,"Di")
-              ,("Mittwoch"   ,"Mi")  
-              ,("Donnerstag" ,"Do") 
-              ,("Freitag"    ,"Fr")
-              ,("Samstag"    ,"Sa")  
-              ]
-  , months  = [("Januar"     ,"Jan")
-              ,("Februar"    ,"Feb")
-              ,("März"       ,"Mär")
-              ,("April"      ,"Apr")
-              ,("Mai"        ,"Mai")
-              ,("Juni"       ,"Jun")
-              ,("Juli"       ,"Jul")
-              ,("August"     ,"Aug")
-              ,("September"  ,"Sep") 
-              ,("Oktober"    ,"Okt")
-              ,("November"   ,"Nov")
-              ,("Dezember"   ,"Dez")
-            ] 
-  , amPm = ("am","pm")
-  , dateTimeFmt = "%a %e.%m.%y %k:%M"
-  , dateFmt     = "%e.%m.%y"
-  , timeFmt     = "%k:%M"
-  , time12Fmt   = "%H:%M"
-  , knownTimeZones = [] -- TODO?
-  }
 
-formatTimeGer ::  FormatTime t => String -> t -> String
+import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime)
-formatTimeGer = formatTime germanTimeLocale
+import qualified Data.Time.Format as Time
 
-formatTimeGerDTlong :: FormatTime t => t -> String
+import Data.Set (Set)
-formatTimeGerDTlong = formatTimeGer "%A, %e. %B %Y, %k:%M:%S"
+import qualified Data.Set as Set
 
-formatTimeGerWDT :: FormatTime t => t -> String
+utcToLocalTime :: UTCTime -> LocalTime
-formatTimeGerWDT = formatTimeGer $ dateTimeFmt germanTimeLocale
+utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
 
-formatTimeGerDT :: FormatTime t => t -> String    --  0.00.00  0:00
+localTimeToUTC :: LocalTime -> LocalToUTCResult
-formatTimeGerDT = formatTimeGer "%e.%m.%y %k:%M"  -- leading spaces at start, otherwise 0 padding
+localTimeToUTC = TZ.localTimeToUTCFull appTZ
 
--- the following is used by DisplayAble's display:
+formatTime' :: (FormatTime t, MonadHandler m, HandlerSite m ~ UniWorX, IsString str) => String -> t -> m str
-formatTimeGerDT2 :: FormatTime t => t -> String   -- Day 00.00.00 00:00
+formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure t
-formatTimeGerDT2 = formatTimeGer "%a %d.%m.%y %H:%M" -- always padding with 0
 
-formatTimeGerWD :: FormatTime t => t -> String
+class FormatTime t => HasLocalTime t where
-formatTimeGerWD = formatTimeGer "%a %e.%m.%y"
+  toLocalTime :: t -> LocalTime
 
-formatTimeGerD :: FormatTime t => t -> String
+instance HasLocalTime LocalTime where
-formatTimeGerD = formatTimeGer $ dateFmt germanTimeLocale
+  toLocalTime = id
 
-formatTimeGerT :: FormatTime t => t -> String
+instance HasLocalTime Day where
-formatTimeGerT = formatTimeGer $ timeFmt germanTimeLocale
+  toLocalTime d = toLocalTime $ UTCTime d 0
+
+instance HasLocalTime UTCTime where
+  toLocalTime t = utcToLocalTime 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) => (DateTimeFormat -> String) -> t -> m Text
+formatTime proj t = flip formatTime' (toLocalTime t) =<< (proj <$> getDateTimeFormat)
+
+getTimeLocale :: (MonadHandler m, HandlerSite m ~ UniWorX) => m TimeLocale
+getTimeLocale = getTimeLocale' <$> languages
+
+getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => m DateTimeFormat
+getDateTimeFormat = do
+  mauth <- liftHandlerT maybeAuth
+  let
+    fmt
+      | Just (Entity _ User{..}) <- mauth
+      = userDateTimeFormat
+      | otherwise
+      = def
+  return fmt
+
+validDateTimeFormats :: Set DateTimeFormat
+validDateTimeFormats = Set.fromList $
+  [ DateTimeFormat "%a %d %b %Y %R" "%d.%m.%Y" "%R"
+  , DateTimeFormat "%a %d %b %Y %T" "%d.%m.%Y" "%T"
+  , DateTimeFormat "%a %d %b %Y %R" "%Y-%m-%d" "%R"
+  , DateTimeFormat "%a %d %b %Y %T" "%Y-%m-%d" "%T"
+  ]
+
+dateTimeFormatOptions :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (OptionList DateTimeFormat)
+dateTimeFormatOptions = do
+  now <- liftIO getCurrentTime
+
+  let
+    toOption fmt@DateTimeFormat{..} = do
+      dateTime <- formatTime' dateTimeFormat now
+      date <- formatTime' dateFormat now
+      time <- formatTime' timeFormat now
+      return $ (MsgDateTimeFormatOption dateTime date time, fmt)
+  
+  optionsPairs <=< mapM toOption $ Set.toList validDateTimeFormats

src/Handler/Utils/Form.hs

@@ -17,6 +17,7 @@ import Handler.Utils.Form.Types
 import Handler.Utils.Templates
 
 import Handler.Utils.DateTime
+import qualified Data.Time as Time
 
 import Import
 import qualified Data.Char as Char
@@ -404,11 +405,11 @@ dayTimeField fs mutc = do
 -}
 
 
-utcTimeField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m UTCTime
+utcTimeField :: (Monad m, RenderMessage (HandlerSite m) FormMessage, RenderMessage (HandlerSite m) UniWorXMessage) => Field m UTCTime
 -- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
--- TODO: Verify whether this is UTC or local time from Browser
+-- Browser returns LocalTime
 utcTimeField = Field
-    { fieldParse = parseHelper $ readTime
+    { fieldParse = parseHelperGen $ readTime
     , fieldView = \theId name attrs val isReq ->
         [whamlet|
           $newline never
@@ -420,15 +421,18 @@ utcTimeField = Field
     fieldTimeFormat :: String
     --fieldTimeFormat = "%e.%m.%y %k:%M"
     fieldTimeFormat = "%Y-%m-%dT%H:%M"
-
+    
-    readTime :: Text -> Either FormMessage UTCTime
+    -- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any 
+    readTime :: Text -> Either UniWorXMessage UTCTime
     readTime t =
-      case parseTimeM True germanTimeLocale fieldTimeFormat (T.unpack t) of
+      case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
-        (Just time) -> Right time
+        (Just (LTUUnique time _))     -> Right time
-        Nothing -> Left $ MsgInvalidEntry $ "Datum/Zeit Format: tt.mm.yy hh:mm " ++ t
+        (Just (LTUNone time _))       -> Right time -- FIXME: Should this be an error, too?
+        (Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime
+        Nothing -> Left MsgInvalidDateTimeFormat
 
     showTime :: UTCTime -> Text
-    showTime = fromString . (formatTime germanTimeLocale fieldTimeFormat)
+    showTime = fromString . (Time.formatTime defaultTimeLocale fieldTimeFormat)
 
 
 fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED

src/Import/NoFoundation.hs

@@ -3,20 +3,19 @@ module Import.NoFoundation
     ( module Import
     ) where
 
-import ClassyPrelude.Yesod   as Import
+import ClassyPrelude.Yesod    as Import hiding (formatTime)
-import Model                 as Import
+import Model                  as Import
-import Settings              as Import
+import Settings               as Import
-import Settings.StaticFiles  as Import
+import Settings.StaticFiles   as Import
-import Yesod.Auth            as Import
+import Yesod.Auth             as Import
-import Yesod.Core.Types      as Import (loggerSet)
+import Yesod.Core.Types       as Import (loggerSet)
-import Yesod.Default.Config2 as Import
+import Yesod.Default.Config2  as Import
-import Utils                 as Import
+import Utils                  as Import
 
 
-import Data.Fixed            as Import
+import Data.Fixed             as Import
 
-import CryptoID              as Import
+import CryptoID               as Import
-import Data.UUID             as Import (UUID)
+import Data.UUID              as Import (UUID)
 
-
+import Text.Lucius            as Import
-import Text.Lucius           as Import

src/Model/Types.hs

@@ -38,6 +38,8 @@ import Data.Aeson.TH (deriveJSON, defaultOptions)
 import GHC.Generics (Generic)
 import Data.Typeable (Typeable)
 
+import Data.Default
+
 
 type Points = Centi
 
@@ -294,3 +296,12 @@ instance PathPiece obj => PathPiece (ZIPArchiveName obj) where
       | otherwise = Nothing
 
     toPathPiece (ZIPArchiveName obj) = toPathPiece obj <> ".zip"
+
+data DateTimeFormat = DateTimeFormat
+  { dateTimeFormat, dateFormat, timeFormat :: String }
+  deriving (Eq, Ord, Read, Show)
+$(deriveJSON defaultOptions ''DateTimeFormat)
+derivePersistFieldJSON "DateTimeFormat"
+
+instance Default DateTimeFormat where
+  def = DateTimeFormat "%a %d %b %Y %R" "%d.%m.%Y" "%R"

src/Settings.hs

@@ -24,6 +24,8 @@ import           Yesod.Default.Util          (WidgetFileSettings,
                                               widgetFileNoReload,
                                               widgetFileReload)
 
+import Model
+
 -- | Runtime settings to configure this application. These settings can be
 -- loaded from various sources: defaults, environment variables, config files,
 -- theoretically even a database.
@@ -59,8 +61,9 @@ data AppSettings = AppSettings
     , appSkipCombining          :: Bool
     -- ^ Perform no stylesheet/script combining
 
-    , appDefaultFavourites :: Int
+    , appDefaultTheme           :: Theme
-    -- ^ Initial Value for remembered Favourites
+    , appDefaultMaxFavourites   :: Int
+    , appDefaultDateTimeFormat  :: DateTimeFormat
 
     -- Example app-specific configuration values.
     , appCopyright              :: Text
@@ -75,6 +78,7 @@ data AppSettings = AppSettings
     -- ^ If set authenticate against a local password file
     , appAllowDeprecated        :: Bool
     -- ^ Indicate if deprecated routes are accessible for everyone
+
     }
 
 instance FromJSON AppSettings where
@@ -101,7 +105,9 @@ instance FromJSON AppSettings where
         appMutableStatic          <- o .:? "mutable-static"   .!= defaultDev
         appSkipCombining          <- o .:? "skip-combining"   .!= defaultDev
 
-        appDefaultFavourites      <- o .:  "userDefaultFavourites"
+        appDefaultMaxFavourites   <- o .:  "default-favourites"
+        appDefaultTheme           <- o .:  "default-theme"
+        appDefaultDateTimeFormat  <- o .:  "default-date-time-format"
 
         appCopyright              <- o .:  "copyright"
         appAnalytics              <- o .:? "analytics"

src/Utils.hs

@@ -19,6 +19,7 @@ import qualified Data.Char as Char
 
 import Utils.DB as Utils
 import Utils.Common as Utils
+import Utils.DateTime as Utils
 
 import Text.Blaze (Markup, ToMarkup)
 

src/Utils/DateTime.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+           , QuasiQuotes
+           , StandaloneDeriving
+           , DeriveLift
+  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Utils.DateTime
+  ( timeLocaleMap
+  , TimeLocale(..)
+  , module Data.Time.Zones
+  , module Data.Time.Zones.TH
+  ) where
+
+import ClassyPrelude.Yesod hiding (lift)
+import System.Locale.Read
+
+import Data.Time (TimeZone(..), TimeLocale(..))
+import Data.Time.Zones (TZ)
+import Data.Time.Zones.TH (includeSystemTZ)
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (Lift(..))
+import Instances.TH.Lift ()
+
+deriving instance Lift TimeZone
+deriving instance Lift TimeLocale
+
+-- $(timeLocaleMap _) :: [Lang] -> TimeLocale
+timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default
+              -> ExpQ
+timeLocaleMap [] = fail "Need at least one (language, locale)-pair"
+timeLocaleMap extra@((_, defLocale):_) = do
+  localeMap <- newName "localeMap"
+
+  let
+    localeMap' = funD localeMap $ map matchLang extra ++ [reduceLangList, defaultLang]
+
+    defaultLang :: ClauseQ
+    defaultLang =
+      clause [listP []] (normalB $ localeExp defLocale) []
+
+    reduceLangList :: ClauseQ
+    reduceLangList = do
+      ls <- newName "ls"
+      clause [[p|(_ : $(varP ls))|]] (normalB [e|$(varE localeMap) $(varE ls)|]) []
+
+    matchLang :: (Lang, String) -> ClauseQ
+    matchLang (lang, localeStr) = do
+      lang' <- newName "lang"
+      clause [[p|($(varP lang') : _)|]] (guardedB [(,) <$> normalG [e|$(varE lang') == lang|] <*> localeExp localeStr]) []
+
+    localeExp :: String -> ExpQ
+    localeExp = lift <=< runIO . getLocale . Just
+  
+  letE [localeMap'] (varE localeMap)

src/Utils/Lens.hs

@@ -3,10 +3,10 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FunctionalDependencies #-}
-module Utils.Lens where
+module Utils.Lens ( module Utils.Lens ) where
 
 import Import.NoFoundation
-import Control.Lens
+import Control.Lens as Utils.Lens
 
 makeClassy_ ''Entity
 

stack.yaml

@@ -25,6 +25,10 @@ packages:
       git: https://github.com/pngwjpgh/encoding.git
       commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
     extra-dep: true
+  - location:
+      git: https://github.com/pngwjpgh/system-locale.git
+      commit: d803ce3607ac6813ac1a065acb423220f57dab3c
+    extra-dep: true
 
 extra-deps:
   - colonnade-1.2.0

templates/course.hamlet

@@ -22,13 +22,13 @@
           #{participants}
           $maybe capacity <- courseCapacity course
             \ von #{capacity}
-      $maybe regFrom <- courseRegisterFrom course
+      $maybe regFrom <- mRegFrom
         <dt .deflist__dt>Anmeldezeitraum
         <dd .deflist__dd>
           <div>
-            Ab #{formatTimeGerWD regFrom}
+            Ab #{regFrom}
-            $maybe regTo   <- courseRegisterTo   course
+            $maybe regTo <- mRegTo
-              \ bis #{formatTimeGerWD regTo}
+              \ bis #{regTo}
     $if registrationOpen
       <dt .deflist__dt>
       <dd .deflist__dd>

templates/sheetShow.hamlet

@@ -1,30 +1,23 @@
-<div .masthead>
-    <div .container>
-        <div .row>
-            <h1 .header>
-              #{sheetName sheet}
 <div .container>
-    <div .bs-docs-section>
+  $maybe descr <- sheetDescription sheet
-        <div .row>
+    <h2 #description>Hinweise
-            <div .col-lg-12>
+    <p> #{descr}
-                <div .page-header>                    
 
-                    $maybe descr <- sheetDescription sheet
+  <h3>Bewertung
-                      <h2 #description>Hinweise
+  <p>
-                      <p> #{descr}
+    #{display $ sheetType sheet}
-                    <h3>Bewertung
-                    <p> #{display $ sheetType sheet}
-                      $maybe marking <- sheetMarkingText sheet
-                        <p> #{marking}
-                    <br>
-                    Freigeschaltet ab:
-                    \  #{formatTimeGerWD $ sheetActiveFrom sheet}
-                    \ Abgabe bis:
-                    \  #{formatTimeGerWD $ sheetActiveTo sheet}
 
-        <div .row>
+  $maybe marking <- sheetMarkingText sheet
-            <div .col-lg-12>     
+    <p>
-                <h2>Dateien
+      #{marking}
-                ^{fileTable}
-    <hr>
 
+  <p>
+    Freigeschaltet ab
+    #{sheetFrom}
+
+  <p>
+    Abgabe bis
+    #{sheetTo}
+
+  <h2>Dateien
+  ^{fileTable}

templates/submission.hamlet

@@ -2,10 +2,13 @@ $maybe cID <- mcid
   <section style="padding-bottom:1em; margin-bottom:1em; border-bottom:1px solid black;">
     <h2>
       <a href=@{CSubmissionR tid csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))}>Archiv
-    $forall (name,time) <- lastEdits
+    $if not (null lastEdits)
-      <div>last edited by #{name} at #{formatTimeGerDTlong time}
+      <h3>_{MsgLastEdits}
+      <ul>
+        $forall (name,time) <- lastEdits
+          <li>_{MsgEditedBy name time}
     $maybe fileTable <- mFileTable
-      <h3>Enthaltene Dateien:
+      <h3>_{MsgSubmissionFiles}
       ^{fileTable}
 
 <section>