diff --git a/config/settings.yml b/config/settings.yml index bcd9cabcb..9d787ed7f 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -119,5 +119,6 @@ user-defaults: date-format: "%d.%m.%Y" time-format: "%R" download-files: false + warning-days: 1209600 instance-id: "_env:INSTANCE_ID:instance" diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index b28e5d649..a9603b270 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -596,7 +596,7 @@ MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufget NoTableContent: Kein Tabelleninhalt NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter -NoUpcomingExams: In den nächsten 14 Tagen gibt es keine Prüfung mit offener Registrierung in Ihren Kursen +NoUpcomingExams difftime@Text: In den nächsten #{difftime} gibt es keine Prüfung oder ablaufende Prüfungsanmeldungen in Ihren Kursen AdminHeading: Administration AdminUserHeading: Benutzeradministration @@ -622,6 +622,8 @@ DateFormat: Datumsformat TimeFormat: Uhrzeitformat DownloadFiles: Dateien automatisch herunterladen DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden). +WarningDays: Fristen-Vorschau +WarningDaysTip: Wie viele Tage im Voraus sollen Fristen von Klausuren etc. auf Ihrer Startseite angezeigt werden? NotificationSettings: Erwünschte Benachrichtigungen FormNotifications: Benachrichtigungen FormBehaviour: Verhalten @@ -1484,7 +1486,7 @@ AllocationStaffRegister: Eintragung der Kurse AllocationRegisterFrom: Bewerbung ab AllocationRegister: Bewerbung AllocationRegisterClosed: Die Zentralanmeldung ist aktuell geschlossen. -AllocationRegisterOpensIn opens@Text: Die Zentralanmeldung öffnet voraussichtlich in #{opens} +AllocationRegisterOpensIn difftime@Text: Die Zentralanmeldung öffnet voraussichtlich in #{difftime} AllocationStaffAllocationFrom: Bewertung der Bewerbungen ab AllocationStaffAllocation: Bewerbungsbewertung AllocationProcess: Platzvergabe diff --git a/models/users b/models/users index 21143848c..155970f60 100644 --- a/models/users +++ b/models/users @@ -11,7 +11,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create ident (CI Text) -- Case-insensitive user-identifier authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) lastAuthentication UTCTime Maybe -- last login date - tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null) + tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null) matrikelnummer UserMatriculation Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...) email (CI Text) -- Case-insensitive eMail address displayName UserDisplayName -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained) @@ -23,12 +23,13 @@ User json -- Each Uni2work user has a corresponding row in this table; create dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined - downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this) + downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this) mailLanguages MailLanguages "default='[]'::jsonb" -- Preferred language for eMail; i18n not yet implemented; user-defined - notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined - UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table - UniqueEmail email -- Column 'email' can be used as a row-key in this table - deriving Show Eq Generic -- Haskell-specific settings for runtime-value representing a row in memory + notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined + warningDays NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos + UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table + UniqueEmail email -- Column 'email' can be used as a row-key in this table + deriving Show Eq Generic -- Haskell-specific settings for runtime-value representing a row in memory UserAdmin -- Each row in this table grants school-specific administrator-rights to a specific user user UserId school SchoolId diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs index b9721ab7d..9629800d1 100644 --- a/src/Data/Time/Clock/Instances.hs +++ b/src/Data/Time/Clock/Instances.hs @@ -6,17 +6,27 @@ module Data.Time.Clock.Instances import ClassyPrelude -import Data.Time.Clock +import Database.Persist.Sql + +import Data.Proxy import Data.Binary (Binary) import qualified Data.Binary as Binary +import Data.Time.Clock import Data.Time.Calendar.Instances () instance Hashable DiffTime where hashWithSalt s = hashWithSalt s . toRational +instance PersistField NominalDiffTime where + toPersistValue = toPersistValue . toRational + fromPersistValue = fmap fromRational . fromPersistValue + +instance PersistFieldSql NominalDiffTime where + sqlType _ = sqlType (Proxy @Rational) + deriving instance Generic UTCTime instance Hashable UTCTime @@ -25,5 +35,5 @@ instance Hashable UTCTime instance Binary DiffTime where get = fromRational <$> Binary.get put = Binary.put . toRational - + instance Binary UTCTime diff --git a/src/Foundation.hs b/src/Foundation.hs index e22691223..9748f0b47 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1116,7 +1116,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of E.&&. course E.^. CourseShorthand E.==. E.val csh E.where_ $ E.maybe E.true (E.maybe E.false $ \f -> f E.<=. E.val cTime) (allocation E.?. AllocationStaffAllocationFrom) E.&&. E.maybe E.true (E.maybe E.true $ \t -> t E.>=. E.val cTime) (allocation E.?. AllocationStaffAllocationTo) - + unauthorizedI MsgUnauthorizedParticipant r -> $unsupportedAuthPredicate AuthParticipant r tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of @@ -3058,6 +3058,7 @@ upsertCampusUser ldapData Creds{..} = do , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays , userNotificationSettings = def , userMailLanguages = def , userTokensIssuedAfter = Nothing diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index eec4b71ab..30beb116a 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -129,131 +129,133 @@ homeUpcomingSheets uid = do homeUpcomingExams :: UserId -> Widget homeUpcomingExams uid = do now <- liftIO getCurrentTime - let fortnight = addWeeks 2 now - let -- code copied and slightly adapted from Handler.Course.getCShowR: - examDBTable = DBTable{..} - where - -- for ease of refactoring: - queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) - queryExam = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) - lensCourse = _1 - lensExam = _2 - lensRegister = _3 . _Just - lensOccurrence = _4 . _Just + ((Any hasExams, examTable), warningDays) <- liftHandlerT . runDB $ do + User {userWarningDays} <- get404 uid + let fortnight = addUTCTime userWarningDays now + let -- code copied and slightly adapted from Handler.Course.getCShowR: + examDBTable = DBTable{..} + where + -- for ease of refactoring: + queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) + queryExam = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) + lensCourse = _1 + lensExam = _2 + lensRegister = _3 . _Just + lensOccurrence = _4 . _Just - dbtSQLQuery ((course `E.InnerJoin` exam) `E.LeftOuterJoin` register `E.LeftOuterJoin` occurrence) = do - E.on $ register E.?. ExamRegistrationOccurrence E.==. E.just (occurrence E.?. ExamOccurrenceId) - E.on $ register E.?. ExamRegistrationExam E.==. E.just (exam E.^. ExamId) - E.&&. register E.?. ExamRegistrationUser E.==. E.just (E.val uid) - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ E.exists $ E.from $ \participant -> - E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid - E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId - let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight) - E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now) - E.&&. E.isNothing (register E.?. ExamRegistrationId) - startExamFortnight = exam E.^. ExamStart E.<=. E.just (E.val fortnight) - E.&&. exam E.^. ExamStart E.>=. E.just (E.val now) - E.&&. E.isJust (register E.?. ExamRegistrationId) - startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight) - E.&&. occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now) - E.&&. E.isJust (register E.?. ExamRegistrationId) - earliestOccurrence = E.sub_select $ E.from $ \occ -> do - E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId - E.&&. occ E.^. ExamOccurrenceStart E.>=. E.val now - return $ E.min_ $ occ E.^. ExamOccurrenceStart - startEarliest = E.isNothing (occurrence E.?. ExamOccurrenceId) - E.&&. earliestOccurrence E.<=. E.just (E.val fortnight) - -- E.&&. earliestOccurrence E.>=. E.just (E.val now) - E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest - return (course, exam, register, occurrence) - dbtRowKey = queryExam >>> (E.^. ExamId) - dbtProj r@DBRow{ dbrOutput } = do - let Entity _ Exam{..} = view lensExam dbrOutput - Entity _ Course{..} = view lensCourse dbrOutput - guardM . hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EShowR -- check access rights - return r - dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> - msgCell courseTerm - , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> - msgCell courseSchool - , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> - anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) (toWgt courseShorthand) - -- continue here - , sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do - let Entity _ Exam{..} = view lensExam dbrOutput - Entity _ Course{..} = view lensCourse dbrOutput - indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName - , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom - , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo - , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput } -> - if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput - -> cell $ formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd - | Entity _ Exam{..} <- view lensExam dbrOutput - , Just start <- examStart -> cell $ formatTimeRangeW SelFormatDateTime start examEnd - | otherwise -> mempty - {- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems. - Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers. - , sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do - let Entity eId Exam{..} = view lensExam dbrOutput - Entity _ Course{..} = view lensCourse dbrOutput - mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True - isRegistered <- existsBy $ UniqueExamRegistration eId uid - if - | mayRegister -> do - (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered - return $ wrapForm examRegisterForm def - { formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR - , formEncoding = examRegisterEnctype - , formSubmit = FormNoSubmit - } - | isRegistered -> return [whamlet|_{MsgExamRegistered}|] - | otherwise -> return mempty - -} - , sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do - let Entity _ Exam{..} = view lensExam dbrOutput - Entity _ Course{..} = view lensCourse dbrOutput - mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True - let isRegistered = has lensRegister dbrOutput - label = bool MsgExamNotRegistered MsgExamRegistered isRegistered - examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR - if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl - | otherwise -> return [whamlet|_{label}|] - , sortable (toNothingS "occurrence") (i18nCell MsgExamOccurrence) $ \DBRow{ dbrOutput } -> - if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput - -> textCell examOccurrenceRoom - | otherwise -> mempty - ] - dbtSorting = Map.fromList - [ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName)) - , ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm )) - , ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool )) - , ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand )) - , ("name", SortColumn $ queryExam >>> (E.^. ExamName )) - , ("time", SortColumn $ queryExam >>> (E.^. ExamStart )) - , ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom )) - , ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo )) - , ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom )) - , ("registered", SortColumn $ queryExam >>> (\exam -> - E.exists $ E.from $ \registration -> do - E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid - E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId - )) - ] - dbtFilter = Map.empty - dbtFilterUI = const mempty - dbtStyle = def - dbtParams = def - dbtIdent :: Text - dbtIdent = "exams" - dbtCsvEncode = noCsvEncode - dbtCsvDecode = Nothing + dbtSQLQuery ((course `E.InnerJoin` exam) `E.LeftOuterJoin` register `E.LeftOuterJoin` occurrence) = do + E.on $ register E.?. ExamRegistrationOccurrence E.==. E.just (occurrence E.?. ExamOccurrenceId) + E.on $ register E.?. ExamRegistrationExam E.==. E.just (exam E.^. ExamId) + E.&&. register E.?. ExamRegistrationUser E.==. E.just (E.val uid) + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ E.exists $ E.from $ \participant -> + E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid + E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId + let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight) + E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now) + E.&&. E.isNothing (register E.?. ExamRegistrationId) + startExamFortnight = exam E.^. ExamStart E.<=. E.just (E.val fortnight) + E.&&. exam E.^. ExamStart E.>=. E.just (E.val now) + E.&&. E.isJust (register E.?. ExamRegistrationId) + startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight) + E.&&. occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now) + E.&&. E.isJust (register E.?. ExamRegistrationId) + earliestOccurrence = E.sub_select $ E.from $ \occ -> do + E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId + E.&&. occ E.^. ExamOccurrenceStart E.>=. E.val now + return $ E.min_ $ occ E.^. ExamOccurrenceStart + startEarliest = E.isNothing (occurrence E.?. ExamOccurrenceId) + E.&&. earliestOccurrence E.<=. E.just (E.val fortnight) + -- E.&&. earliestOccurrence E.>=. E.just (E.val now) + E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest + return (course, exam, register, occurrence) + dbtRowKey = queryExam >>> (E.^. ExamId) + dbtProj r@DBRow{ dbrOutput } = do + let Entity _ Exam{..} = view lensExam dbrOutput + Entity _ Course{..} = view lensCourse dbrOutput + guardM . hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EShowR -- check access rights + return r + dbtColonnade = dbColonnade $ mconcat + [ sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> + msgCell courseTerm + , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> + msgCell courseSchool + , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> + anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) (toWgt courseShorthand) + -- continue here + , sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do + let Entity _ Exam{..} = view lensExam dbrOutput + Entity _ Course{..} = view lensCourse dbrOutput + indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName + , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom + , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo + , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput } -> + if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput + -> cell $ formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd + | Entity _ Exam{..} <- view lensExam dbrOutput + , Just start <- examStart -> cell $ formatTimeRangeW SelFormatDateTime start examEnd + | otherwise -> mempty + {- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems. + Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers. + , sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do + let Entity eId Exam{..} = view lensExam dbrOutput + Entity _ Course{..} = view lensCourse dbrOutput + mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True + isRegistered <- existsBy $ UniqueExamRegistration eId uid + if + | mayRegister -> do + (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered + return $ wrapForm examRegisterForm def + { formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR + , formEncoding = examRegisterEnctype + , formSubmit = FormNoSubmit + } + | isRegistered -> return [whamlet|_{MsgExamRegistered}|] + | otherwise -> return mempty + -} + , sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do + let Entity _ Exam{..} = view lensExam dbrOutput + Entity _ Course{..} = view lensCourse dbrOutput + mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True + let isRegistered = has lensRegister dbrOutput + label = bool MsgExamNotRegistered MsgExamRegistered isRegistered + examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR + if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl + | otherwise -> return [whamlet|_{label}|] + , sortable (toNothingS "occurrence") (i18nCell MsgExamOccurrence) $ \DBRow{ dbrOutput } -> + if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput + -> textCell examOccurrenceRoom + | otherwise -> mempty + ] + dbtSorting = Map.fromList + [ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName)) + , ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm )) + , ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool )) + , ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand )) + , ("name", SortColumn $ queryExam >>> (E.^. ExamName )) + , ("time", SortColumn $ queryExam >>> (E.^. ExamStart )) + , ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom )) + , ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo )) + , ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom )) + , ("registered", SortColumn $ queryExam >>> (\exam -> + E.exists $ E.from $ \registration -> do + E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid + E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId + )) + ] + dbtFilter = Map.empty + dbtFilterUI = const mempty + dbtStyle = def + dbtParams = def + dbtIdent :: Text + dbtIdent = "exams" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing - examDBTableValidator = def - & defaultSorting [SortAscBy "time"] + examDBTableValidator = def + & defaultSorting [SortAscBy "time"] - (Any hasExams, examTable) <- liftHandlerT . runDB $ dbTable examDBTableValidator examDBTable + (, userWarningDays) <$> dbTable examDBTableValidator examDBTable $(widgetFile "home/upcomingExams") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index f5f897135..e4a08f547 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -24,6 +24,7 @@ data SettingsForm = SettingsForm , stgDate :: DateTimeFormat , stgTime :: DateTimeFormat , stgDownloadFiles :: Bool + , stgWarningDays :: NominalDiffTime , stgNotificationSettings :: NotificationSettings } @@ -50,6 +51,9 @@ makeSettingForm template html = do <*> apopt checkBoxField (fslI MsgDownloadFiles & setTooltip MsgDownloadFilesTip ) (stgDownloadFiles <$> template) + <*> areq daysField (fslI MsgWarningDays + & setTooltip MsgWarningDaysTip + ) (stgWarningDays <$> template) <* aformSection MsgFormNotifications <*> notificationForm (stgNotificationSettings <$> template) return (result, widget) -- no validation required here @@ -181,6 +185,7 @@ postProfileR = do , stgTime = userTimeFormat , stgDownloadFiles = userDownloadFiles , stgNotificationSettings = userNotificationSettings + , stgWarningDays = userWarningDays } ((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate diff --git a/src/Settings.hs b/src/Settings.hs index 3a4d80938..7bec37cb8 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -112,7 +112,7 @@ data AppSettings = AppSettings , appMaximumContentLength :: Maybe Word64 , appJwtExpiration :: Maybe NominalDiffTime , appJwtEncoding :: JwtEncoding - + , appHealthCheckInterval :: HealthCheck -> Maybe NominalDiffTime , appHealthCheckDelayNotify :: Bool , appHealthCheckHTTP :: Bool @@ -159,8 +159,9 @@ data UserDefaultConf = UserDefaultConf , userDefaultMaxFavourites :: Int , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat , userDefaultDownloadFiles :: Bool + , userDefaultWarningDays :: NominalDiffTime } deriving (Show) - + data PWHashConf = PWHashConf { pwHashAlgorithm :: PWHashAlgorithm , pwHashStrength :: Int @@ -189,7 +190,7 @@ data LdapConf = LdapConf , ldapSearchTimeout :: Int32 , ldapPool :: ResourcePoolConf } deriving (Show) - + data SmtpConf = SmtpConf { smtpHost :: HaskellNet.HostName , smtpPort :: HaskellNet.PortNumber @@ -223,7 +224,7 @@ instance FromJSON WidgetMemcachedConf where connectionIdleTime <- o .: "timeout" widgetMemcachedBaseUrl <- o .: "base-url" widgetMemcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration" - + return WidgetMemcachedConf{ widgetMemcachedConnectInfo = Memcached.ConnectInfo{..}, .. } data ResourcePoolConf = ResourcePoolConf @@ -251,7 +252,7 @@ deriveJSON defaultOptions deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } ''LogSettings - + deriveFromJSON defaultOptions ''Ldap.Scope deriveFromJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 8a4f951ac..36afaa515 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -41,6 +41,7 @@ import Data.UUID import Data.Ratio ((%)) import Data.Fixed import Data.Scientific +import Data.Time.Clock (NominalDiffTime, nominalDay) import Utils -- import Utils.Message @@ -565,6 +566,13 @@ intMinMaxField lower upper = intF{ fieldView=newView } newView theId name attrs val isReq = oldView theId name (newAttrs <> attrs) val isReq newAttrs = [ (a,tshow v) | (a,Just v) <- [("min", lower),("max", upper)] ] +daysField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m NominalDiffTime +daysField = convertField toDays fromDays fractionalField + where + toDays = (/ nominalDay) + fromDays = (* nominalDay) + + data SecretJSONFieldException = SecretJSONFieldDecryptFailure deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Exception SecretJSONFieldException diff --git a/templates/home/upcomingExams.hamlet b/templates/home/upcomingExams.hamlet index 1bb40bb09..29ee05df4 100644 --- a/templates/home/upcomingExams.hamlet +++ b/templates/home/upcomingExams.hamlet @@ -4,4 +4,4 @@ $newline never $if hasExams ^{examTable} $else - _{MsgNoUpcomingExams} + _{MsgNoUpcomingExams (formatDiffDays warningDays)} diff --git a/test/Database.hs b/test/Database.hs index f90167b21..fc4396918 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -103,6 +103,7 @@ fillDb = do , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays , userMailLanguages = MailLanguages ["en"] , userNotificationSettings = def } @@ -123,6 +124,7 @@ fillDb = do , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays , userMailLanguages = MailLanguages ["de"] , userNotificationSettings = def } @@ -143,6 +145,7 @@ fillDb = do , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays , userMailLanguages = MailLanguages ["de"] , userNotificationSettings = def } @@ -163,6 +166,7 @@ fillDb = do , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays , userMailLanguages = MailLanguages ["de"] , userNotificationSettings = def } @@ -183,6 +187,7 @@ fillDb = do , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays , userMailLanguages = MailLanguages ["de"] , userNotificationSettings = def } @@ -203,6 +208,7 @@ fillDb = do , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays , userMailLanguages = MailLanguages ["de"] , userNotificationSettings = def } diff --git a/test/TestImport.hs b/test/TestImport.hs index ea4c4e7d3..d198ab41a 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -125,6 +125,7 @@ createUser adjUser = do userDateFormat = userDefaultDateFormat userTimeFormat = userDefaultTimeFormat userDownloadFiles = userDefaultDownloadFiles + userWarningDays = userDefaultWarningDays userMailLanguages = def userNotificationSettings = def runDB . insertEntity $ adjUser User{..}