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

Merge branch 'feat/timezones' into 'staging'

Browse Source 
Timezones, date formatting & minor cleanup

See merge request !45
This commit is contained in:
Gregor Kleen 2018-07-09 23:12:37 +02:00
commit 0e6a8cc964
23 changed files with 280 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
config/settings.yml
View File

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

8
db.hs
View File

@ -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

11
messages/de.msg
View File

@ -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}

7
models
View File

@ -4,8 +4,9 @@ User json
matrikelnummer Text Maybe
email Text
displayName Text
maxFavourites Int default=12
theme Theme default='default'
maxFavourites Int
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

3
package.yaml
View File

@ -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.

19
src/Foundation.hs
View File

@ -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
userTheme = Default -- TODO: appDefaultFavourites appSettings
userMaxFavourites = appDefaultMaxFavourites
userTheme = appDefaultTheme
userDateTimeFormat = appDefaultDateTimeFormat
newUser = User{..}
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
, UserDisplayName =. userDisplayName

6
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{..}, _) -> textCell $ display courseRegisterFrom
, sortable (Just "register-to") (textCell MsgRegisterTo) $ \(Entity _ Course{..}, _) -> textCell $ display courseRegisterTo
, 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 "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")

6
src/Handler/Home.hs
View File

@ -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

9
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" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
, headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3
, headed "Abgabe ab" $ \(_,Sheet{..},_) -> formatTime dateTimeFormat sheetActiveFrom >>= toWidget
, 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

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)
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

16
src/Handler/Term.hs
View File

@ -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

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

@ -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
germanTimeLocale = TimeLocale
{ 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?
}
import Data.Time.Zones hiding (localTimeToUTCFull)
import qualified Data.Time.Zones as TZ
formatTimeGer :: FormatTime t => String -> t -> String
formatTimeGer = formatTime germanTimeLocale
import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime)
import qualified Data.Time.Format as Time
formatTimeGerDTlong :: FormatTime t => t -> String
formatTimeGerDTlong = formatTimeGer "%A, %e. %B %Y, %k:%M:%S"
import Data.Set (Set)
import qualified Data.Set as Set
formatTimeGerWDT :: FormatTime t => t -> String
formatTimeGerWDT = formatTimeGer $ dateTimeFmt germanTimeLocale
utcToLocalTime :: UTCTime -> LocalTime
utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
formatTimeGerDT :: FormatTime t => t -> String -- 0.00.00 0:00
formatTimeGerDT = formatTimeGer "%e.%m.%y %k:%M" -- leading spaces at start, otherwise 0 padding
localTimeToUTC :: LocalTime -> LocalToUTCResult
localTimeToUTC = TZ.localTimeToUTCFull appTZ
-- the following is used by DisplayAble's display:
formatTimeGerDT2 :: FormatTime t => t -> String -- Day 00.00.00 00:00
formatTimeGerDT2 = formatTimeGer "%a %d.%m.%y %H:%M" -- always padding with 0
formatTime' :: (FormatTime t, MonadHandler m, HandlerSite m ~ UniWorX, IsString str) => String -> t -> m str
formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure t
formatTimeGerWD :: FormatTime t => t -> String
formatTimeGerWD = formatTimeGer "%a %e.%m.%y"
class FormatTime t => HasLocalTime t where
toLocalTime :: t -> LocalTime
formatTimeGerD :: FormatTime t => t -> String
formatTimeGerD = formatTimeGer $ dateFmt germanTimeLocale
instance HasLocalTime LocalTime where
toLocalTime = id
formatTimeGerT :: FormatTime t => t -> String
formatTimeGerT = formatTimeGer $ timeFmt germanTimeLocale
instance HasLocalTime Day where
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

22
src/Handler/Utils/Form.hs
View File

@ -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
(Just time) -> Right time
Nothing -> Left $ MsgInvalidEntry $ "Datum/Zeit Format: tt.mm.yy hh:mm " ++ t
case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
(Just (LTUUnique time _)) -> Right time
(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

25
src/Import/NoFoundation.hs
View File

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

11
src/Model/Types.hs
View File

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

12
src/Settings.hs
View File

@ -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
-- ^ Initial Value for remembered Favourites
, appDefaultTheme :: Theme
, 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"

1
src/Utils.hs
View File

@ -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)

57
src/Utils/DateTime.hs Normal file
View File

@ -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)

4
src/Utils/Lens.hs
View File

@ -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

4
stack.yaml
View File

@ -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

8
templates/course.hamlet
View File

@ -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}
$maybe regTo <- courseRegisterTo course
\ bis #{formatTimeGerWD regTo}
Ab #{regFrom}
$maybe regTo <- mRegTo
\ bis #{regTo}
$if registrationOpen
<dt .deflist__dt>
<dd .deflist__dd>

45
templates/sheetShow.hamlet
View File

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

9
templates/submission.hamlet
View File

@ -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
<div>last edited by #{name} at #{formatTimeGerDTlong time}
$if not (null lastEdits)
<h3>_{MsgLastEdits}
<ul>
$forall (name,time) <- lastEdits
<li>_{MsgEditedBy name time}
$maybe fileTable <- mFileTable
<h3>Enthaltene Dateien:
<h3>_{MsgSubmissionFiles}
^{fileTable}
<section>