feat(home): allow users to define exam warning time

Closes #445

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"

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

models/users

@@ -26,6 +26,7 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     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
+    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

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

src/Foundation.hs

@@ -3058,6 +3058,7 @@ upsertCampusUser ldapData Creds{..} = do
       , userDateFormat           = userDefaultDateFormat
       , userTimeFormat           = userDefaultTimeFormat
       , userDownloadFiles        = userDefaultDownloadFiles
+      , userWarningDays          = userDefaultWarningDays
       , userNotificationSettings = def
       , userMailLanguages        = def
       , userTokensIssuedAfter    = Nothing

src/Handler/Home.hs

@@ -129,7 +129,9 @@ homeUpcomingSheets uid = do
 homeUpcomingExams :: UserId -> Widget
 homeUpcomingExams uid = do
   now <- liftIO getCurrentTime
-  let fortnight = addWeeks 2 now
+  ((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
@@ -253,7 +255,7 @@ homeUpcomingExams uid = do
       examDBTableValidator = def
         & defaultSorting [SortAscBy "time"]
 
-  (Any hasExams, examTable) <- liftHandlerT . runDB $ dbTable examDBTableValidator examDBTable
+    (, userWarningDays) <$> dbTable examDBTableValidator examDBTable
 
   $(widgetFile "home/upcomingExams")
 

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
 

src/Settings.hs

@@ -159,6 +159,7 @@ data UserDefaultConf = UserDefaultConf
   , userDefaultMaxFavourites :: Int
   , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
   , userDefaultDownloadFiles :: Bool
+  , userDefaultWarningDays :: NominalDiffTime
   } deriving (Show)
 
 data PWHashConf = PWHashConf

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

templates/home/upcomingExams.hamlet

@@ -4,4 +4,4 @@ $newline never
   $if hasExams
     ^{examTable}
   $else
-    _{MsgNoUpcomingExams}
+    _{MsgNoUpcomingExams (formatDiffDays warningDays)}

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
     }

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{..}