From 239c96d90748f962dd56f67af2de4bd1d83e3456 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 9 Jul 2018 23:07:26 +0200 Subject: [PATCH] Timezones, date formatting & minor cleanup --- config/settings.yml | 7 +- db.hs | 8 ++- messages/de.msg | 11 ++- models | 7 +- package.yaml | 3 + src/Foundation.hs | 19 ++++-- src/Handler/Course.hs | 6 +- src/Handler/Home.hs | 6 +- src/Handler/Sheet.hs | 9 +-- src/Handler/Submission.hs | 2 +- src/Handler/Term.hs | 16 +++-- src/Handler/Utils/DateTime.hs | 125 +++++++++++++++++++++------------- src/Handler/Utils/Form.hs | 22 +++--- src/Import/NoFoundation.hs | 25 ++++--- src/Model/Types.hs | 11 +++ src/Settings.hs | 12 +++- src/Utils.hs | 1 + src/Utils/DateTime.hs | 57 ++++++++++++++++ src/Utils/Lens.hs | 4 +- stack.yaml | 4 ++ templates/course.hamlet | 8 +-- templates/sheetShow.hamlet | 45 ++++++------ templates/submission.hamlet | 9 ++- 23 files changed, 280 insertions(+), 137 deletions(-) create mode 100644 src/Utils/DateTime.hs diff --git a/config/settings.yml b/config/settings.yml index c3ff0ecf3..0a6647c97 100644 --- a/config/settings.yml +++ b/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" diff --git a/db.hs b/db.hs index a0f980180..8b038debd 100755 --- a/db.hs +++ b/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 diff --git a/messages/de.msg b/messages/de.msg index ea407972e..4188502e7 100644 --- a/messages/de.msg +++ b/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 \ No newline at end of file +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} \ No newline at end of file diff --git a/models b/models index 909a72610..49c6fc524 100644 --- a/models +++ b/models @@ -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 diff --git a/package.yaml b/package.yaml index 1f2496141..6f6de5fd2 100644 --- a/package.yaml +++ b/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. diff --git a/src/Foundation.hs b/src/Foundation.hs index 8a307908b..cc692b35e 100644 --- a/src/Foundation.hs +++ b/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 - userTheme = Default -- TODO: appDefaultFavourites appSettings + userMaxFavourites = appDefaultMaxFavourites + userTheme = appDefaultTheme + userDateTimeFormat = appDefaultDateTimeFormat newUser = User{..} userUpdate = [ UserMatrikelnummer =. userMatrikelnummer , UserDisplayName =. userDisplayName diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index d4e2c529b..17a3ee853 100644 --- a/src/Handler/Course.hs +++ b/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-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") diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index b5e0b7412..89fc83136 100644 --- a/src/Handler/Home.hs +++ b/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|#{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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 1ddbd051c..2b093af0f 100644 --- a/src/Handler/Sheet.hs +++ b/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 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 diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 5ff6058a1..4c6fe2d7f 100644 --- a/src/Handler/Submission.hs +++ b/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 diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 22782165f..240b9c9f6 100644 --- a/src/Handler/Term.hs +++ b/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| +