Profile notification settings

messages/uniworx/de.msg

@@ -274,6 +274,7 @@ 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).
+NotificationSettings: Erwünschte Benachrichtigungen
 
 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
@@ -320,8 +321,8 @@ MailTestDateTime: Test der Datumsformattierung:
 German: Deutsch
 GermanGermany: Deutsch (Deutschland)
 
-MailSubjectSubmissionRated csh@CourseShorthand: Ihre #{csh}-Abgabe wurde bewertet
+MailSubjectSubmissionRated csh@CourseShorthand: Ihre #{csh}-Abgabe wurde korrigiert
-MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{courseName} (#{termDesc}) wurde bewertet.
+MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{courseName} (#{termDesc}) wurde korrigiert.
 
 MailSubjectSheetActive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} wurde herausgegeben
 MailSheetActiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen.
@@ -347,4 +348,9 @@ SheetGroupRegisteredGroups: Registrierte Gruppen
 SheetGroupNoGroups: Keine Gruppenabgabe
 SheetGroupMaxGroupsize: Maximale Gruppengröße
 
-SheetFiles: Übungsblatt-Dateien
+SheetFiles: Übungsblatt-Dateien
+
+NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übungsblatt wurde korrigiert
+NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert
+NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen
+NotificationTriggerSheetInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben

src/Foundation.hs

@@ -89,6 +89,8 @@ import qualified Data.Yaml as Yaml
 
 import Text.Shakespeare.Text (st)
 
+import Yesod.Form.I18n.German
+
 
 instance DisplayAble b => DisplayAble (E.CryptoID a b) where
   display = display . ciphertext
@@ -180,7 +182,8 @@ mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
 -- This instance is required to use forms. You can modify renderMessage to
 -- achieve customized and internationalized form validation messages.
 instance RenderMessage UniWorX FormMessage where
-    renderMessage _ _ = defaultFormMessage
+    renderMessage f (l:ls) = renderMessage f ls -- TODO
+    renderMessage _ [] = germanFormMessage
 
 instance RenderMessage UniWorX TermIdentifier where
   renderMessage foundation ls TermIdentifier{..} = case season of
@@ -189,10 +192,9 @@ instance RenderMessage UniWorX TermIdentifier where
     where renderMessage' = renderMessage foundation ls
 
 instance RenderMessage UniWorX StudyFieldType where
-  renderMessage foundation ls = \case
+  renderMessage foundation ls = renderMessage foundation ls . \case
-    FieldPrimary -> renderMessage' MsgFieldPrimary
+    FieldPrimary -> MsgFieldPrimary
-    FieldSecondary -> renderMessage' MsgFieldSecondary
+    FieldSecondary -> MsgFieldSecondary
-    where renderMessage' = renderMessage foundation ls
 
 newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
   deriving (Eq, Ord, Read, Show)
@@ -207,35 +209,31 @@ instance RenderMessage UniWorX String where
   renderMessage f ls str = renderMessage f ls $ Text.pack str
 
 instance RenderMessage UniWorX SheetFileType where
-  renderMessage foundation ls = \case
+  renderMessage foundation ls = renderMessage foundation ls . \case
-      SheetExercise -> renderMessage' MsgSheetExercise
+      SheetExercise -> MsgSheetExercise
-      SheetHint     -> renderMessage' MsgSheetHint
+      SheetHint     -> MsgSheetHint
-      SheetSolution -> renderMessage' MsgSheetSolution
+      SheetSolution -> MsgSheetSolution
-      SheetMarking  -> renderMessage' MsgSheetMarking
+      SheetMarking  -> MsgSheetMarking
-    where renderMessage' = renderMessage foundation ls
 
 instance RenderMessage UniWorX CorrectorState where
-  renderMessage foundation ls = \case
+  renderMessage foundation ls = renderMessage foundation ls . \case
-      CorrectorNormal  -> renderMessage' MsgCorrectorNormal
+      CorrectorNormal  -> MsgCorrectorNormal
-      CorrectorMissing -> renderMessage' MsgCorrectorMissing
+      CorrectorMissing -> MsgCorrectorMissing
-      CorrectorExcused -> renderMessage' MsgCorrectorExcused
+      CorrectorExcused -> MsgCorrectorExcused
-    where renderMessage' = renderMessage foundation ls
 
 
 instance RenderMessage UniWorX Load where
-  renderMessage foundation ls = \case
+  renderMessage foundation ls = renderMessage foundation ls . \case
-      (Load {byTutorial=Nothing   , byProportion=p}) -> renderMessage' $ MsgCorByProportionOnly p
+      (Load {byTutorial=Nothing   , byProportion=p}) -> MsgCorByProportionOnly p
-      (Load {byTutorial=Just True , byProportion=p}) -> renderMessage' $ MsgCorByProportionIncludingTutorial p
+      (Load {byTutorial=Just True , byProportion=p}) -> MsgCorByProportionIncludingTutorial p
-      (Load {byTutorial=Just False, byProportion=p}) -> renderMessage' $ MsgCorByProportionExcludingTutorial p
+      (Load {byTutorial=Just False, byProportion=p}) -> MsgCorByProportionExcludingTutorial p
-    where renderMessage' = renderMessage foundation ls
 
 instance RenderMessage UniWorX SheetType where
-  renderMessage foundation ls = \case
+  renderMessage foundation ls = renderMessage foundation ls . \case
-      Bonus{..} -> renderMessage' $ MsgSheetTypeBonus' maxPoints
+      Bonus{..} -> MsgSheetTypeBonus' maxPoints
-      Normal{..} -> renderMessage' $ MsgSheetTypeNormal' maxPoints
+      Normal{..} -> MsgSheetTypeNormal' maxPoints
-      Pass{..} -> renderMessage' $ MsgSheetTypePass' maxPoints passingPoints
+      Pass{..} -> MsgSheetTypePass' maxPoints passingPoints
-      NotGraded{} -> renderMessage' MsgSheetTypeNotGraded'
+      NotGraded{} -> MsgSheetTypeNotGraded'
-    where renderMessage' = renderMessage foundation ls
 
 newtype MsgLanguage = MsgLanguage Lang
   deriving (Eq, Ord, Show, Read)
@@ -246,6 +244,13 @@ instance RenderMessage UniWorX MsgLanguage where
     where
       mr = renderMessage foundation ls
 
+instance RenderMessage UniWorX NotificationTrigger where
+  renderMessage foundation ls = renderMessage foundation ls . \case
+    NTSubmissionRatedGraded -> MsgNotificationTriggerSubmissionRatedGraded
+    NTSubmissionRated -> MsgNotificationTriggerSubmissionRated
+    NTSheetActive -> MsgNotificationTriggerSheetActive
+    NTSheetInactive -> MsgNotificationTriggerSheetInactive
+
 
 instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
   renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)

src/Handler/Profile.hs

@@ -24,6 +24,8 @@ import Utils.Lens
 -- import Yesod.Colonnade
 import Data.Monoid (Any(..))
 import qualified Data.Map as Map
+import Data.Map ((!))
+import qualified Data.Set as Set
 -- import qualified Data.Set as Set
 import qualified Database.Esqueleto as E
 -- import           Database.Esqueleto      ((^.))
@@ -37,6 +39,7 @@ data SettingsForm = SettingsForm
       , stgDate          :: DateTimeFormat
       , stgTime          :: DateTimeFormat
       , stgDownloadFiles :: Bool
+      , stgNotificationSettings :: NotificationSettings
       }
 
 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
@@ -53,13 +56,30 @@ makeSettingForm template = identForm FIDsettings $ \html -> do
       <*> areq checkBoxField (fslI MsgDownloadFiles
                                & setTooltip MsgDownloadFilesTip
                              ) (stgDownloadFiles <$> template)
+      <*> formToAForm (nsFieldView =<< renderAForm FormStandard nsForm mempty)
       <*  submitButton
     return (result, widget) -- no validation required here
+  where
+    nsForm = fmap (\m -> NotificationSettings $ \nt -> m ! nt) . sequenceA . flip Map.fromSet (Set.fromList universeF) $ \nt ->
+      areq checkBoxField (fslI nt) (flip notificationAllowed nt . stgNotificationSettings <$> template)
+    nsFieldView :: (FormResult NotificationSettings, Widget) -> MForm Handler (FormResult NotificationSettings, [FieldView UniWorX])
+    nsFieldView (res, fvInput) = do
+      mr <- getMessageRender
+      let fvLabel = toHtml $ mr MsgNotificationSettings
+          fvTooltip = mempty
+          fvRequired = True
+          fvErrors
+            | FormFailure (err:_) <- res = Just $ toHtml err
+            | otherwise = Nothing
+      fvId <- newIdent
+      return (res, pure FieldView{..})
+    -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
 
 
 
-getProfileR :: Handler Html
+getProfileR, postProfileR :: Handler Html
-getProfileR = do
+getProfileR = postProfileR
+postProfileR = do
   (uid, User{..}) <- requireAuthPair
   let settingsTemplate = Just $ SettingsForm
         { stgMaxFavourties = userMaxFavourites
@@ -68,6 +88,7 @@ getProfileR = do
         , stgDate          = userDateFormat
         , stgTime          = userTimeFormat
         , stgDownloadFiles = userDownloadFiles
+        , stgNotificationSettings = userNotificationSettings
         }
   ((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate
   case res of
@@ -79,6 +100,7 @@ getProfileR = do
                       , UserDateFormat     =. stgDate
                       , UserTimeFormat     =. stgTime
                       , UserDownloadFiles  =. stgDownloadFiles
+                      , UserNotificationSettings =. stgNotificationSettings
                       ]
           when (stgMaxFavourties < userMaxFavourites) $ do
             -- prune Favourites to user-defined size
@@ -135,11 +157,6 @@ getProfileR = do
     $(widgetFile "profile")
     $(widgetFile "dsgvDisclaimer")
 
-postProfileR :: Handler Html
-postProfileR = do
-  -- TODO
-  getProfileR
-
 postProfileDataR  :: Handler Html
 postProfileDataR = do
   (uid, User{..}) <- requireAuthPair

src/Jobs.hs

@@ -468,7 +468,7 @@ performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..},
   addAlternatives $ do
     provideAlternative $ Aeson.object
       [ "submission" Aeson..= ciphertext csid
-      , "submission-rating-points" Aeson..= submissionRatingPoints
+      , "submission-rating-points" Aeson..= (guard (sheetType /= NotGraded) *> submissionRatingPoints)
       , "submission-rating-comment" Aeson..= submissionRatingComment
       , "submission-rating-time" Aeson..= submissionRatingTime
       , "submission-rating-by" Aeson..= (userDisplayName <$> corrector)