fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'feat/timezones' into 'staging'

Browse Source 
Split DateTimeFormat up into three fields

See merge request !47
This commit is contained in:
Gregor Kleen 2018-07-10 10:55:50 +02:00
commit e28e32a14f
11 changed files with 91 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
config/settings.yml
View File

@ -42,10 +42,9 @@ ldap:
default-favourites: 12
default-theme: Default
default-date-time-format:
dateTimeFormat: "%a %d %b %Y %R"
dateFormat: "%d.%m.%Y"
timeFormat: "%R"
default-date-time-format: "%a %d %b %Y %R"
default-date-format: "%d.%m.%Y"
default-time-format: "%R"
cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf"

8
models
View File

@ -4,9 +4,11 @@ User json
matrikelnummer Text Maybe
email Text
displayName Text
maxFavourites Int
theme Theme
dateTimeFormat DateTimeFormat
maxFavourites Int default=12
theme Theme default='Default'
dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'"
dateFormat DateTimeFormat "default='%d.%m.%Y'"
timeFormat DateTimeFormat "default='%R'"
UniqueAuthentication plugin ident
UniqueEmail email
deriving Show

2
src/Foundation.hs
View File

@ -1009,6 +1009,8 @@ instance YesodAuth UniWorX where
userMaxFavourites = appDefaultMaxFavourites
userTheme = appDefaultTheme
userDateTimeFormat = appDefaultDateTimeFormat
userDateFormat = appDefaultDateFormat
userTimeFormat = appDefaultTimeFormat
newUser = User{..}
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
, UserDisplayName =. userDisplayName

8
src/Handler/Course.hs
View File

@ -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{..}, _) -> cell $ traverse (formatTime dateTimeFormat) courseRegisterFrom >>= maybe mempty toWidget
, sortable (Just "register-to") (textCell MsgRegisterTo) $ \(Entity _ Course{..}, _) -> cell $ traverse (formatTime dateTimeFormat) courseRegisterTo >>= maybe mempty toWidget
, sortable (Just "register-from") (textCell MsgRegisterFrom) $ \(Entity _ Course{..}, _) -> cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget
, sortable (Just "register-to") (textCell MsgRegisterTo) $ \(Entity _ Course{..}, _) -> cell $ traverse (formatTime SelFormatDateTime) 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,8 +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
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
defaultLayout $ do
setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|]
$(widgetFile "course")

4
src/Handler/Home.hs
View File

@ -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}) } ->
cell $ traverse (formatTime dateTimeFormat) (courseRegisterTo course) >>= maybe mempty toWidget
cell $ traverse (formatTime SelFormatDateTime) (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, _) } ->
cell $ formatTime dateTimeFormat deadline >>= toWidget
cell $ formatTime SelFormatDateTime 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

10
src/Handler/Sheet.hs
View File

@ -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" $ \(_,Sheet{..},_) -> formatTime dateTimeFormat sheetActiveFrom >>= toWidget
, headed "Abgabe bis" $ \(_,Sheet{..},_) -> formatTime dateTimeFormat sheetActiveTo >>= toWidget
, headed "Abgabe ab" $ \(_,Sheet{..},_) -> formatTime SelFormatDateTime sheetActiveFrom >>= toWidget
, headed "Abgabe bis" $ \(_,Sheet{..},_) -> formatTime SelFormatDateTime 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,_) -> cell $ formatTime dateTimeFormat (modified :: UTCTime) >>= toWidget
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
]
fileTable <- dbTable def $ DBTable
{ dbtSQLQuery = fileData
@ -244,8 +244,8 @@ getSShowR tid csh shn = do
}
defaultLayout $ do
setTitle $ toHtml $ T.append "Übung " $ sheetName sheet
sheetFrom <- formatTime dateTimeFormat $ sheetActiveFrom sheet
sheetTo <- formatTime dateTimeFormat $ sheetActiveTo sheet
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
$(widgetFile "sheetShow")
getSFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent

2
src/Handler/Submission.hs
View File

@ -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)
lastEdits <- forM lastEditValues $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime dateTimeFormat time
lastEdits <- forM lastEditValues $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
return (sheet,buddies,lastEdits)
let unpackZips = True -- undefined -- TODO
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping $ map E.unValue buddies

10
src/Handler/Term.hs
View File

@ -46,20 +46,20 @@ getTermShowR = do
anchorCell' (\(Entity tid _, _) -> TermCourseListR tid)
(\(Entity tid _, _) -> [whamlet|#{display tid}|])
, sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) ->
cell $ formatTime dateFormat termLectureStart >>= toWidget
cell $ formatTime SelFormatDate termLectureStart >>= toWidget
, sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) ->
cell $ formatTime dateFormat termLectureEnd >>= toWidget
cell $ formatTime SelFormatDate 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{..},_) ->
cell $ formatTime dateFormat termStart >>= toWidget
cell $ formatTime SelFormatDate termStart >>= toWidget
, sortable (Just "end") "Semesterende" $ \(Entity _ Term{..},_) ->
cell $ formatTime dateFormat termEnd >>= toWidget
cell $ formatTime SelFormatDate termEnd >>= toWidget
, sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
cell $ do
termHolidays' <- mapM (formatTime dateFormat) termHolidays
termHolidays' <- mapM (formatTime SelFormatDate) termHolidays
[whamlet|
<ul .list--inline .list--comma-separated>
$forall holiday <- termHolidays'

76
src/Handler/Utils/DateTime.hs
View File

@ -31,7 +31,7 @@ utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
localTimeToUTC :: LocalTime -> LocalToUTCResult
localTimeToUTC = TZ.localTimeToUTCFull appTZ
formatTime' :: (FormatTime t, MonadHandler m, HandlerSite m ~ UniWorX, IsString str) => String -> t -> m str
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
@ -41,47 +41,81 @@ instance HasLocalTime LocalTime where
toLocalTime = id
instance HasLocalTime Day where
toLocalTime d = toLocalTime $ UTCTime d 0
toLocalTime d = LocalTime d midnight
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)
formatTime :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> t -> m Text
formatTime proj t = flip formatTime' (toLocalTime t) =<< (unDateTimeFormat <$> getDateTimeFormat proj)
getTimeLocale :: (MonadHandler m, HandlerSite m ~ UniWorX) => m TimeLocale
getTimeLocale = getTimeLocale' <$> languages
getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => m DateTimeFormat
getDateTimeFormat = do
getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat
getDateTimeFormat sel = do
mauth <- liftHandlerT maybeAuth
AppSettings{..} <- getsYesod appSettings
let
fmt
| Just (Entity _ User{..}) <- mauth
= userDateTimeFormat
= case sel of
SelFormatDateTime -> userDateTimeFormat
SelFormatDate -> userDateFormat
SelFormatTime -> userTimeFormat
| otherwise
= def
= case sel of
SelFormatDateTime -> appDefaultDateTimeFormat
SelFormatDate -> appDefaultDateFormat
SelFormatTime -> appDefaultTimeFormat
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"
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, %d %B %Y %R"
, DateTimeFormat "%a %d %b %Y %T"
, DateTimeFormat "%A, %d %B %Y %T"
, DateTimeFormat "%d.%m.%Y %R"
, DateTimeFormat "%d.%m.%Y %T"
, DateTimeFormat "%R %d.%m.%Y"
, DateTimeFormat "%T %d.%m.%Y"
, DateTimeFormat "%Y-%m-%d %R"
, DateTimeFormat "%Y-%m-%d %T"
, DateTimeFormat "%Y-%m-%dT%T"
]
validDateTimeFormats _ SelFormatDate = Set.fromList $
[ DateTimeFormat "%a %d %b %Y"
, DateTimeFormat "%A, %d %B %Y"
, DateTimeFormat "%d.%m.%Y"
, DateTimeFormat "%Y-%m-%d"
]
validDateTimeFormats TimeLocale{..} SelFormatTime = Set.fromList . concat . catMaybes $
[ Just
[ DateTimeFormat "%R"
, DateTimeFormat "%T"
]
, do
guard $ uncurry (/=) amPm
Just
[ DateTimeFormat "%I:%M %p"
, DateTimeFormat "%I:%M %P"
, DateTimeFormat "%I:%M:%S %p"
, DateTimeFormat "%I:%M:%S %P"
]
]
dateTimeFormatOptions :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (OptionList DateTimeFormat)
dateTimeFormatOptions = do
dateTimeFormatOptions :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m (OptionList DateTimeFormat)
dateTimeFormatOptions sel = do
now <- liftIO getCurrentTime
tl <- getTimeLocale
let
toOption fmt@DateTimeFormat{..} = do
dateTime <- formatTime' dateTimeFormat now
date <- formatTime' dateFormat now
time <- formatTime' timeFormat now
return $ (MsgDateTimeFormatOption dateTime date time, fmt)
dateTime <- formatTime' unDateTimeFormat now
return $ (dateTime, fmt)
optionsPairs <=< mapM toOption $ Set.toList validDateTimeFormats
optionsPairs <=< mapM toOption . Set.toList $ validDateTimeFormats tl sel

15
src/Model/Types.hs
View File

@ -3,7 +3,7 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE ViewPatterns #-}
{-- # LANGUAGE ExistentialQuantification #-} -- for DA type
@ -38,8 +38,6 @@ import Data.Aeson.TH (deriveJSON, defaultOptions)
import GHC.Generics (Generic)
import Data.Typeable (Typeable)
import Data.Default
type Points = Centi
@ -297,11 +295,8 @@ instance PathPiece obj => PathPiece (ZIPArchiveName obj) where
toPathPiece (ZIPArchiveName obj) = toPathPiece obj <> ".zip"
data DateTimeFormat = DateTimeFormat
{ dateTimeFormat, dateFormat, timeFormat :: String }
deriving (Eq, Ord, Read, Show)
$(deriveJSON defaultOptions ''DateTimeFormat)
derivePersistFieldJSON "DateTimeFormat"
newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
deriving (Eq, Ord, Read, Show, ToJSON, FromJSON, PersistField, PersistFieldSql)
instance Default DateTimeFormat where
def = DateTimeFormat "%a %d %b %Y %R" "%d.%m.%Y" "%R"
data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
deriving (Eq, Ord, Read, Show, Enum, Bounded)

4
src/Settings.hs
View File

@ -64,6 +64,8 @@ data AppSettings = AppSettings
, appDefaultTheme :: Theme
, appDefaultMaxFavourites :: Int
, appDefaultDateTimeFormat :: DateTimeFormat
, appDefaultDateFormat :: DateTimeFormat
, appDefaultTimeFormat :: DateTimeFormat
-- Example app-specific configuration values.
, appCopyright :: Text
@ -108,6 +110,8 @@ instance FromJSON AppSettings where
appDefaultMaxFavourites <- o .: "default-favourites"
appDefaultTheme <- o .: "default-theme"
appDefaultDateTimeFormat <- o .: "default-date-time-format"
appDefaultDateFormat <- o .: "default-date-format"
appDefaultTimeFormat <- o .: "default-time-format"
appCopyright <- o .: "copyright"
appAnalytics <- o .:? "analytics"