Wire in NotificationSubmissionRated

db.hs

@@ -83,6 +83,7 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userNotificationSettings = def
     }
   fhamann <- insert User
     { userIdent  = "felix.hamann@campus.lmu.de"
@@ -97,6 +98,7 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userNotificationSettings = def
     }
   jost <- insert User
     { userIdent  = "jost@tcs.ifi.lmu.de"
@@ -111,6 +113,7 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userNotificationSettings = def
     }
   void . insert $ User
     { userIdent  = "max@campus.lmu.de"
@@ -125,6 +128,7 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userNotificationSettings = def
     }
   void . insert $ User
     { userIdent  = "tester@campus.lmu.de"
@@ -139,6 +143,7 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userNotificationSettings = def
     }
   void . repsert (TermKey summer2017) $ Term
     { termName     = summer2017

messages/uniworx/de.msg

@@ -317,3 +317,6 @@ MailTestContent: Dies ist eine Test-Email versandt von Uni2Work. Von Ihrer Seite
 
 German: Deutsch
 GermanGermany: Deutsch (Deutschland)
+
+MailSubjectSubmissionRated csh@CourseShorthand: Ihre #{csh}-Abgabe wurde bewertet
+MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{courseName} (#{termDesc}) wurde bewertet.

models

@@ -11,6 +11,8 @@ User json
     dateFormat     DateTimeFormat "default='%d.%m.%Y'"
     timeFormat     DateTimeFormat "default='%R'"
     downloadFiles  Bool default=false
+    mailLanguages  MailLanguages "default='[]'"
+    notificationSettings NotificationSettings
     UniqueAuthentication ident
     UniqueEmail email
     deriving Show

package.yaml

@@ -101,6 +101,7 @@ dependencies:
 - resource-pool
 - mime-mail
 - hashable
+- aeson-pretty
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Foundation.hs

@@ -1255,12 +1255,14 @@ instance YesodAuth UniWorX where
 
           let
             newUser = User
-              { userMaxFavourites  = userDefaultMaxFavourites
+              { userMaxFavourites        = userDefaultMaxFavourites
-              , userTheme          = userDefaultTheme
+              , userTheme                = userDefaultTheme
-              , userDateTimeFormat = userDefaultDateTimeFormat
+              , userDateTimeFormat       = userDefaultDateTimeFormat
-              , userDateFormat     = userDefaultDateFormat
+              , userDateFormat           = userDefaultDateFormat
-              , userTimeFormat     = userDefaultTimeFormat
+              , userTimeFormat           = userDefaultTimeFormat
-              , userDownloadFiles  = userDefaultDownloadFiles
+              , userDownloadFiles        = userDefaultDownloadFiles
+              , userNotificationSettings = def
+              , userMailLanguages        = def
               , ..
               }
             userUpdate =  [ UserMatrikelnummer =. userMatrikelnummer

src/Handler/Admin.hs

@@ -63,9 +63,12 @@ postAdminTestR = do
 
   ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm "email" $ renderAForm FormStandard emailTestForm
   case emailResult of 
-    (FormSuccess (email, ls)) -> runDB $ do
+    (FormSuccess (email, ls)) -> do
-      (fromSqlKey -> jId) <- queueJob $ JobSendTestEmail email ls
+      jId <- runDB $ do
-      addMessage Success [shamlet|Email-test gestartet (Job ##{tshow jId})|]
+        jId <- queueJob $ JobSendTestEmail email ls
+        addMessage Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|]
+        return jId
+      writeJobCtl $ JobCtlPerform jId
     FormMissing -> return ()
     (FormFailure errs) -> forM_ errs $ addMessage Error . toHtml
   

src/Handler/Corrections.hs

@@ -21,6 +21,7 @@ module Handler.Corrections where
 import Import
 -- import System.FilePath (takeFileName)
 
+import Jobs
 import Handler.Utils
 import Handler.Utils.Submission
 import Handler.Utils.Table.Cells
@@ -463,11 +464,13 @@ postCorrectionR tid ssh csh shn cid = do
         FormMissing -> return ()
         FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
         FormSuccess (ratingPoints, ratingComment) -> do
-          runDB $ do
+          notify <- runDB $ do
             uid <- liftHandlerT requireAuthId
             now <- liftIO getCurrentTime
 
-            let rated = isJust $ void ratingPoints <|> void ratingComment
+            let rated = isJust $ void ratingPoints -- <|> void ratingComment -- Comment shouldn't cause rating
+
+            Submission{submissionRatingTime} <- getJust sub
           
             update sub [ SubmissionRatingBy      =. (uid <$ guard rated)
 -- SJ: I don't think we need to update AssignedTime here, since this is just for correction upload
@@ -478,6 +481,12 @@ postCorrectionR tid ssh csh shn cid = do
                        ]
 
             addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
+
+            return $ rated && isNothing submissionRatingTime
+
+          when notify $
+            queueJob' . JobQueueNotification $ NotificationSubmissionRated sub
+
           redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
 
       case uploadResult of
@@ -486,7 +495,8 @@ postCorrectionR tid ssh csh shn cid = do
         FormSuccess fileSource -> do
           uid <- requireAuthId
           
-          runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
+          (_, mjId) <- runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
+          traverse (writeJobCtl . JobCtlPerform) mjId
 
           addMessageI Success MsgRatingFilesUpdated
           redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
@@ -521,7 +531,8 @@ postCorrectionsUploadR = do
     FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
     FormSuccess files -> do
       uid <- requireAuthId
-      subs <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True
+      (subs, jobs) <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True
+      forM_ jobs $ writeJobCtl . JobCtlPerform
       if
         | null subs -> addMessageI Warning MsgNoCorrectionsUploaded
         | otherwise -> do

src/Handler/Submission.hs

@@ -232,8 +232,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
           smid <- case (mFiles, msmid) of
             (Nothing, Just smid)   -- no new files, existing submission partners updated
               -> return smid
-            (Just files, _)  -- new files
+            (Just files, _) -> -- new files
-              -> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
+              fmap fst . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
             (Nothing, Nothing) -- new submission, no file upload requested
               -> insert Submission
                   { submissionSheet = shid

src/Handler/Utils.hs

@@ -25,6 +25,7 @@ import Handler.Utils.Rating     as Handler.Utils hiding (extractRatings)
 import Handler.Utils.Submission as Handler.Utils
 import Handler.Utils.Sheet      as Handler.Utils
 import Handler.Utils.Templates  as Handler.Utils
+import Handler.Utils.Mail       as Handler.Utils
 
 
 downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool

src/Handler/Utils/Mail.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE NoImplicitPrelude
+           , NamedFieldPuns
+           , TypeFamilies
+           , FlexibleContexts
+           , ViewPatterns
+  #-}
+
+module Handler.Utils.Mail
+  ( addRecipientsDB
+  , userMailT
+  , addFileDB
+  ) where
+
+import Import hiding ((.=))
+
+import Utils.Lens hiding (snoc)
+
+import qualified Data.CaseInsensitive as CI
+
+import qualified Data.ByteString.Lazy as LBS
+
+import qualified Data.Conduit.List as C
+
+import System.FilePath (takeBaseName)
+import Network.Mime (defaultMimeLookup)
+
+import Control.Monad.Trans.State (StateT)
+
+
+addRecipientsDB :: ( MonadMail m
+                   , MonadHandler m
+                   , HandlerSite m ~ UniWorX
+                   ) => [Filter User] -> m ()
+-- ^ @setRecipientId uid@ throws an exception if @uid@ does not refer to an existing user
+addRecipientsDB uFilter = runConduit $ transPipe (liftHandlerT . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient
+  where
+    addRecipient (Entity _ User{userEmail, userDisplayName}) = do
+      let addr = Address (Just userDisplayName) $ CI.original userEmail
+      _mailTo %= flip snoc addr
+
+userMailT :: ( MonadHandler m
+             , HandlerSite m ~ UniWorX
+             , MonadBaseControl IO m
+             , MonadLogger m
+             ) => UserId -> MailT m a -> m a
+userMailT uid mAct = do
+  User{userEmail, userDisplayName, userMailLanguages} <- liftHandlerT . runDB $ getJust uid
+  let addr = Address (Just userDisplayName) $ CI.original userEmail
+  mailT userMailLanguages $ do
+    _mailTo .= pure addr
+    mAct
+
+addFileDB :: ( MonadMail m
+             , MonadHandler m
+             , HandlerSite m ~ UniWorX
+             ) => FileId -> m MailObjectId
+addFileDB fId = do
+  File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- liftHandlerT . runDB $ getJust fId
+  addPart $ do
+    _partType .= decodeUtf8 (defaultMimeLookup fileName)
+    _partEncoding .= Base64
+    _partFilename .= Just fileName
+    _partContent .= LBS.fromStrict fileContent
+    setMailObjectId' fId :: StateT Part (HandlerT UniWorX IO) MailObjectId

src/Handler/Utils/Submission.hs

@@ -11,6 +11,7 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiWayIf #-}
 
 
 module Handler.Utils.Submission
@@ -25,6 +26,7 @@ module Handler.Utils.Submission
   ) where
 
 import Import hiding ((.=), joinPath)
+import Jobs
 import Prelude (lcm)
 import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 
@@ -38,7 +40,7 @@ import Control.Monad.RWS.Lazy (RWST)
 import qualified Control.Monad.Random as Rand
 import qualified System.Random.Shuffle as Rand (shuffleM)
 
-import Data.Maybe
+import Data.Maybe ()
 
 import qualified Data.List as List
 import Data.Set (Set)
@@ -279,6 +281,7 @@ submissionMultiArchive (Set.toList -> ids) = do
 data SubmissionSinkState = SubmissionSinkState
   { sinkSeenRating :: Any
   , sinkSubmissionTouched :: Any
+  , sinkSubmissionNotifyRating :: Any
   , sinkFilenames :: Set FilePath
   } deriving (Show, Eq, Generic, Typeable)
 
@@ -333,7 +336,7 @@ extractRatingsMsg = do
 sinkSubmission :: UserId
                -> Either SheetId SubmissionId
                -> Bool -- ^ Is this a correction
-               -> Sink SubmissionContent (YesodDB UniWorX) SubmissionId
+               -> Sink SubmissionContent (YesodDB UniWorX) (SubmissionId, Maybe QueuedJobId)
 -- ^ Replace the currently saved files for the given submission (either
 --   corrected files or original ones, depending on arguments) with the supplied
 --   'SubmissionContent'.
@@ -359,13 +362,13 @@ sinkSubmission userId mExists isUpdate = do
       return sId
     Right sId -> return sId
 
-  sId <$ sinkSubmission' sId isUpdate
+  (,) <$> pure sId <*> sinkSubmission' sId isUpdate
   where
     tell = modify . mappend
 
     sinkSubmission' :: SubmissionId
                     -> Bool -- ^ Is this a correction
-                    -> Sink SubmissionContent (YesodDB UniWorX) ()
+                    -> Sink SubmissionContent (YesodDB UniWorX) (Maybe QueuedJobId)
     sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
       Left file@(File{..}) -> do
         $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle)
@@ -468,13 +471,16 @@ sinkSubmission userId mExists isUpdate = do
           alreadyTouched <- gets $ getAny . sinkSubmissionTouched
           when (not alreadyTouched) $ do
             now <- liftIO getCurrentTime
-            lift $ case isUpdate of
+            case isUpdate of
-              False -> insert_ $ SubmissionEdit userId now submissionId
+              False -> lift . insert_ $ SubmissionEdit userId now submissionId
-              True  -> update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
+              True  -> do
-                        -- TODO: Should submissionRatingAssigned change here if userId changes?
+                Submission{submissionRatingTime} <- lift $ getJust submissionId
+                when (isNothing submissionRatingTime) $ tell mempty { sinkSubmissionNotifyRating = Any True }
+                lift $ update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
+                -- TODO: Should submissionRatingAssigned change here if userId changes?
             tell $ mempty{ sinkSubmissionTouched = Any True }
 
-        finalize :: SubmissionSinkState -> YesodDB UniWorX ()
+        finalize :: SubmissionSinkState -> YesodDB UniWorX (Maybe QueuedJobId)
         finalize SubmissionSinkState{..} = do
           missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
             E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
@@ -509,13 +515,19 @@ sinkSubmission userId mExists isUpdate = do
                   update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ]
                   deleteCascade fileId
 
-          when (isUpdate && not (getAny sinkSeenRating)) $
+          if
-            update submissionId
+            | isUpdate
+            , not $ getAny sinkSeenRating
+              -> Nothing <$ update submissionId
               [ SubmissionRatingTime =. Nothing
               , SubmissionRatingPoints =. Nothing
               , SubmissionRatingBy =. Nothing
               , SubmissionRatingComment =. Nothing
               ]
+            | isUpdate
+            , getAny sinkSubmissionNotifyRating
+              -> fmap Just . queueJob . JobQueueNotification $ NotificationSubmissionRated submissionId
+            | otherwise -> return Nothing
 
 data SubmissionMultiSinkException
   = SubmissionSinkException
@@ -529,7 +541,7 @@ instance Exception SubmissionMultiSinkException
 
 sinkMultiSubmission :: UserId
                     -> Bool {-^ Are these corrections -}
-                    -> Sink SubmissionContent (YesodDB UniWorX) (Set SubmissionId)
+                    -> Sink SubmissionContent (YesodDB UniWorX) (Set SubmissionId, Set QueuedJobId)
                
 -- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'.
 --
@@ -543,7 +555,7 @@ sinkMultiSubmission userId isUpdate = do
          -> RWST
               ()
               _
-              (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId))
+              (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) (SubmissionId, Maybe QueuedJobId)))
               (YesodDB UniWorX)
               ()
     feed sId val = do
@@ -593,10 +605,10 @@ sinkMultiSubmission userId isUpdate = do
   when (not $ null ignored) $ do
     mr <- (toHtml .) <$> getMessageRender
     addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
-  fmap Map.keysSet . lift . sequence $ flip Map.mapWithKey sinks $ \sId sink -> do
+  lift . fmap (bimap Set.fromList (Set.fromList . catMaybes) . unzip) . forM (Map.toList sinks) $ \(sId, sink) -> do
     cID <- encrypt sId
     handle (throwM . SubmissionSinkException cID Nothing) $
-      void $ closeResumableSink sink
+      closeResumableSink sink
   where
     handleHCError :: Either CryptoFileNameSubmission FilePath -> HandlerContents -> _ (Maybe a)
     handleHCError ident (HCError NotFound) = Nothing <$ tell (Set.singleton ident)

src/Jobs.hs

@@ -8,16 +8,18 @@
            , DeriveGeneric
            , DeriveDataTypeable
            , QuasiQuotes
+           , NamedFieldPuns
   #-}
 
 module Jobs
   ( module Jobs.Types
   , writeJobCtl
-  , queueJob
+  , queueJob, queueJob'
   , handleJobs
   ) where
 
 import Import hiding ((.=))
+import Handler.Utils.Mail
 
 import Jobs.Types
 
@@ -37,6 +39,12 @@ import Utils.Lens
 
 import Control.Monad.Random (evalRand, uniform, mkStdGen)
 
+import qualified Database.Esqueleto as E
+
+import qualified Data.CaseInsensitive as CI
+
+import Text.Hamlet
+
   
 data JobQueueException = JInvalid QueuedJobId QueuedJob
                        | JLocked QueuedJobId InstanceId UTCTime
@@ -77,10 +85,10 @@ handleJobs' wNum = C.mapM_ $ void . handleAny ($logErrorS logIdent . tshow) . ha
       
       $logDebugS logIdent . LT.toStrict . decodeUtf8 $ Aeson.encode content
 
-      Last jobDone <- execWriterT $ performJob content
+      performJob content
 
-      when (fromMaybe True jobDone) $ 
+      -- `performJob` is expected to throw a notification if it detects that the job was not done
-        runDB $ delete jId
+      runDB $ delete jId
 
 jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a
 jLocked jId act = do
@@ -112,34 +120,75 @@ writeJobCtl cmd = do
   chan <- flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) . uniform <$> getsYesod appJobCtl
   liftIO . atomically $ writeTMChan chan cmd
 
-queueJob :: Job -> YesodDB UniWorX QueuedJobId
+queueJobUnsafe :: Job -> YesodDB UniWorX QueuedJobId
-queueJob job = do
+queueJobUnsafe job = do
-  jId <- setSerializable $ do
+  now <- liftIO getCurrentTime
-    now <- liftIO getCurrentTime
+  self <- getsYesod appInstanceID
-    self <- getsYesod appInstanceID
+  insert QueuedJob
-    insert QueuedJob
+    { queuedJobContent = toJSON job
-      { queuedJobContent = toJSON job
+    , queuedJobCreationInstance = self
-      , queuedJobCreationInstance = self
+    , queuedJobCreationTime = now
-      , queuedJobCreationTime = now
+    , queuedJobLockInstance = Nothing
-      , queuedJobLockInstance = Nothing
+    , queuedJobLockTime = Nothing
-      , queuedJobLockTime = Nothing
+    }
-      }
+  -- We should not immediately notify a worker; instead wait for the transaction to finish first
-  writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
+  -- writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
-  return jId
+  -- return jId
+
+queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId
+queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe
+
+queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m ()
+-- ^ `queueJob` followed by `JobCtlPerform`
+queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform
 
 setSerializable :: DB a -> DB a
-setSerializable act = do
+setSerializable = ([executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *>)
-  transactionSave
-  [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|]
-  act <* transactionSave
 
-performJob :: Job -> WriterT (Last Bool) (HandlerT UniWorX IO) ()
+performJob :: Job -> HandlerT UniWorX IO ()
-performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, .. } = do
+performJob JobQueueNotification{ jNotification = n@NotificationSubmissionRated{..} } = do
-  $logDebugS "Jobs" "NotificationSubmissionRated"
+  jIds <- runDB . setSerializable $ do
-  fail "NotificationSubmissionRated not implemented yet" -- TODO
+    Submission{submissionSheet} <- getJust nSubmission
-performJob JobSendTestEmail{..} = do
+    isGraded <- (/= NotGraded) . sheetType <$> getJust submissionSheet
-  $logInfoS "Jobs" $ "Sending test-email to " <> jEmail
+    res <- E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
-  mailT jLanguages $ do
+      E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
-    _mailTo .= [Address Nothing jEmail]
+      E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
-    setSubjectI MsgMailTestSubject
+      return (user E.^. UserId, user E.^. UserNotificationSettings)
-    addPart $ \(MsgRenderer mr) -> mr MsgMailTestContent
+    let recipients = do
+          (E.Value uid, E.Value nSettings) <- res
+          guard . notificationAllowed nSettings $ bool NTSubmissionRated NTSubmissionRatedGraded isGraded
+          return uid
+    forM recipients $ queueJobUnsafe . flip JobSendNotification n
+  forM_ jIds $ writeJobCtl . JobCtlPerform
+performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, jRecipient } = userMailT jRecipient $ do
+  (Course{..}, Sheet{..}, Submission{..}) <- liftHandlerT . runDB $ do
+    submission <- getJust nSubmission
+    sheet <- belongsToJust submissionSheet submission
+    course <- belongsToJust sheetCourse sheet
+    return (course, sheet, submission)
+  csId <- encrypt nSubmission
+  setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand
+
+  MsgRenderer mr <- getMailMsgRenderer
+  let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
+
+  -- TODO: provide convienience template-haskell for `addAlternatives`
+  addAlternatives $ do
+    provideAlternative $ Aeson.object
+      [ "submission" Aeson..= (ciphertext csId :: UUID)
+      , "submission-rating-points" Aeson..= submissionRatingPoints
+      , "submission-rating-comment" Aeson..= submissionRatingComment
+      , "submission-rating-time" Aeson..= submissionRatingTime
+      , "sheet-name" Aeson..= sheetName
+      , "sheet-type" Aeson..= sheetType
+      , "course-name" Aeson..= courseName
+      , "course-shorthand" Aeson..= courseShorthand
+      , "course-term" Aeson..= courseTerm
+      , "course-school" Aeson..= courseSchool
+      ]
+    provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX))
+    providePreferredAlternative $ \(MsgRenderer mr) -> ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
+performJob JobSendTestEmail{..} = mailT jLanguages $ do
+  _mailTo .= [Address Nothing jEmail]
+  setSubjectI MsgMailTestSubject
+  addPart $ \(MsgRenderer mr) -> mr MsgMailTestContent

src/Jobs/Types.hs

@@ -17,6 +17,7 @@ import Data.Aeson.TH (deriveJSON)
 
 data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
          | JobSendTestEmail { jEmail :: Text, jLanguages :: MailLanguages }
+         | JobQueueNotification { jNotification :: Notification }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)

src/Mail.hs

@@ -13,6 +13,9 @@
            , ViewPatterns
            , NamedFieldPuns
            , MultiWayIf
+           , QuasiQuotes
+           , RankNTypes
+           , ScopedTypeVariables
   #-}
 
 module Mail
@@ -22,6 +25,7 @@ module Mail
   , MailT, defMailT
   , MailSmtpData(..), MailLanguages(..)
   , MonadMail(..)
+  , getMailMessageRender, getMailMsgRenderer
     -- * YesodMail
   , VerpMode(..)
   , YesodMail(..)
@@ -72,8 +76,10 @@ import qualified Data.Foldable as Foldable
 import Data.Hashable
 
 import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Builder as LTB
 import qualified Data.ByteString.Lazy as LBS
 
+import Utils (MsgRendererS(..))
 import Utils.Lens.TH
 import Control.Lens
 
@@ -97,11 +103,14 @@ import Data.Time.Format
 import Network.HaskellNet.SMTP (SMTPConnection)
 import qualified Network.HaskellNet.SMTP as SMTP
 
-import qualified Text.Hamlet as Shakespeare (Translate, Render)
+import qualified Text.Hamlet as Hamlet (Translate)
+import qualified Text.Shakespeare as Shakespeare (RenderUrl)
 
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Encode.Pretty as Aeson
 import Data.Aeson (Options(..))
 import Data.Aeson.TH
-import Utils (MsgRendererS, getMsgRenderer)
+import Utils (MsgRendererS(..))
 import Utils.PathPiece (splitCamel)
 
 
@@ -115,7 +124,7 @@ newtype MailT m a = MailT { unMailT :: RWST MailLanguages MailSmtpData Mail m a
                    , MonadState Mail, MonadWriter MailSmtpData, MonadReader MailLanguages
                    )
 
-instance (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => MonadCrypto (MailT m) where
+instance {-# OVERLAPPING #-} (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => MonadCrypto (MailT m) where
   type MonadCryptoKey (MailT m) = CryptoIDKey
   cryptoIDKey f = lift (cryptoIDKey return) >>= f
 
@@ -155,11 +164,19 @@ deriveJSON defaultOptions
   , sumEncoding = UntaggedValue
   } ''VerpMode
 
-getMessageRender :: ( MonadMail m
+getMailMessageRender :: ( MonadMail m
-                    , HandlerSite m ~ site
+                        , HandlerSite m ~ site
-                    , RenderMessage site msg
+                        , RenderMessage site msg
-                    ) => m (msg -> Text)
+                        ) => m (msg -> Text)
-getMessageRender = renderMessage <$> getYesod <*> (mailLanguages <$> askMailLanguages)
+getMailMessageRender = renderMessage <$> getYesod <*> (mailLanguages <$> askMailLanguages)
+
+getMailMsgRenderer :: forall site m.
+                      ( MonadMail m
+                      , HandlerSite m ~ site
+                      ) => m (MsgRendererS site)
+getMailMsgRenderer = do
+  mr <- getMailMessageRender
+  return $ MsgRenderer (mr . SomeMessage :: RenderMessage site msg => msg -> Text)
 
 
 data MailException = MailNotAvailable
@@ -170,7 +187,7 @@ data MailException = MailNotAvailable
 instance Exception MailException
   
 
-class YesodMail site where
+class Yesod site => YesodMail site where
   defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
   defaultFromAddress = (Address Nothing . ("yesod@" <>) . pack) <$> liftIO getHostName
 
@@ -198,6 +215,25 @@ class YesodMail site where
            ) => MailLanguages -> MailT m a -> m a
   mailT = defMailT
 
+  defaultMailLayout :: ( MonadHandler m
+                       , HandlerSite m ~ site
+                       ) => WidgetT site IO () -> m Html
+  defaultMailLayout wgt = do
+    PageContent{..} <- liftHandlerT $ widgetToPageContent wgt
+    msgs <- getMessages
+    withUrlRenderer [hamlet|
+      $newline never
+      $doctype 5
+      <html>
+        <head>
+          <title>#{pageTitle}
+          ^{pageHead}
+        <body>
+          $forall (status, msg) <- msgs
+            <p class="message #{status}">#{msg}
+        ^{pageBody}
+    |]
+
 defMailT :: ( MonadHandler m
             , YesodMail (HandlerSite m)
             , MonadBaseControl IO m
@@ -234,62 +270,81 @@ instance Monoid (PrioritisedAlternatives m) where
   mempty = memptydefault
   mappend = mappenddefault
 
-class ToMailPart site a where
+class YesodMail site => ToMailPart site a where
-  toMailPart :: (MonadHandler m, HandlerSite m ~ site) => a -> StateT Part m ()
+  type MailPartReturn site a :: *
+  type MailPartReturn site a = ()
+  toMailPart :: (MonadMail m, HandlerSite m ~ site) => a -> StateT Part m (MailPartReturn site a)
 
-instance ToMailPart site (StateT Part (HandlerT site IO) ()) where
+instance YesodMail site => ToMailPart site (StateT Part (HandlerT site IO) a) where
+  type MailPartReturn site (StateT Part (HandlerT site IO) a) = a
   toMailPart = mapStateT liftHandlerT
 
-instance ToMailPart site LT.Text where
+instance YesodMail site => ToMailPart site LT.Text where
   toMailPart text = do
     _partType .= "text/plain"
     _partEncoding .= QuotedPrintableText
     _partContent .= encodeUtf8 text
 
-instance ToMailPart site Text where
+instance YesodMail site => ToMailPart site Text where
   toMailPart = toMailPart . LT.fromStrict
 
-instance ToMailPart site Html where
+instance YesodMail site => ToMailPart site LTB.Builder where
+  toMailPart = toMailPart . LTB.toLazyText
+
+instance YesodMail site => ToMailPart site Html where
   toMailPart html = do
     _partType .= "text/html"
     _partEncoding .= QuotedPrintableText
     _partContent .= renderMarkup html
 
-instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Shakespeare.Translate msg -> a) where
+instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Hamlet.Translate msg -> a) where
+  type MailPartReturn site (Hamlet.Translate msg -> a) = MailPartReturn site a
   toMailPart act = do
-    mr <- Yesod.getMessageRender
+    mr <- lift getMailMessageRender
     toMailPart $ act (toHtml . mr)
 
 instance (ToMailPart site a, site ~ site') => ToMailPart site (MsgRendererS site' -> a) where
+  type MailPartReturn site (MsgRendererS site' -> a) = MailPartReturn site a
   toMailPart act = do
-    mr <- getMsgRenderer
+    mr <- lift getMailMsgRenderer
     toMailPart $ act mr
 
-instance ToMailPart site a => ToMailPart site (Shakespeare.Render (Route site) -> a) where
+instance ToMailPart site a => ToMailPart site (Shakespeare.RenderUrl (Route site) -> a) where
+  type MailPartReturn site (Shakespeare.RenderUrl (Route site) -> a) = MailPartReturn site a
   toMailPart act = do
     ur <- getUrlRenderParams
     toMailPart $ act ur
 
+instance YesodMail site => ToMailPart site Aeson.Value where
+  toMailPart val = do
+    _partType .= "application/json"
+    _partEncoding .= QuotedPrintableText
+    _partContent .= Aeson.encodePretty val
 
-addAlternatives :: Monad m
+
+addAlternatives :: (MonadMail m)
                 => Writer (PrioritisedAlternatives m) ()
-                -> MailT m ()
+                -> m ()
-addAlternatives provided = MailT $ do
+addAlternatives provided = do
   let PrioritisedAlternatives{..} = execWriter provided
-  alternatives <- lift . sequence . Foldable.toList $ maybe id (flip (Seq.|>)) (getLast preferredAlternative) otherAlternatives
+  alternatives <- sequence . Foldable.toList $ maybe id (flip (Seq.|>)) (getLast preferredAlternative) otherAlternatives
   modify $ Mime.addPart alternatives
 
 provideAlternative, providePreferredAlternative
-  :: (MonadHandler m, HandlerSite m ~ site, ToMailPart site a)
+  :: (MonadMail m, HandlerSite m ~ site, ToMailPart site a)
   => a
   -> Writer (PrioritisedAlternatives m) ()
 provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT (toMailPart part) initialPart }
 providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT (toMailPart part) initialPart }
 
-addPart :: (MonadHandler m, HandlerSite m ~ site, ToMailPart site a) => a -> MailT m ()
+addPart :: ( MonadMail m
-addPart part = MailT $ do
+           , HandlerSite m ~ site
-  part' <- lift $ execStateT (toMailPart part) initialPart
+           , ToMailPart site a
+           ) => a -> m (MailPartReturn site a)
+addPart part = do
+  (ret, part') <- runStateT (toMailPart part) initialPart
   modify . Mime.addPart $ pure part'
+  return ret
 
 initialPart :: Part
 initialPart = Part
@@ -340,13 +395,15 @@ addMailHeaderI :: ( RenderMessage site msg
                   , HandlerSite m ~ site
                   , MonadHeader m
                   ) => MailHeader -> msg -> m ()
-addMailHeaderI header msg = addMailHeader header =<< (getMessageRender <*> pure msg)
+addMailHeaderI header msg = addMailHeader header =<< (getMailMessageRender <*> pure msg)
 
 
 setSubjectI :: (RenderMessage site msg, MonadHandler m, HandlerSite m ~ site) => msg -> MailT m ()
 setSubjectI = replaceMailHeaderI "Subject"
 
-setMailObjectUUID :: (MonadHandler m, YesodMail (HandlerSite m)) => UUID -> MailT m MailObjectId
+setMailObjectUUID :: ( MonadHeader m
+                     , YesodMail (HandlerSite m)
+                     ) => UUID -> m MailObjectId
 setMailObjectUUID uuid = do
   domain <- mailObjectIdDomain
   oidHeader <- objectIdHeader
@@ -354,17 +411,19 @@ setMailObjectUUID uuid = do
   replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">"
   return objectId
 
-setMailObjectId :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m MailObjectId
+setMailObjectId :: ( MonadHeader m
+                   , YesodMail (HandlerSite m)
+                   ) => m MailObjectId
 setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom
 
-setMailObjectId' :: ( MonadHandler m
+setMailObjectId' :: ( MonadHeader m
                     , YesodMail (HandlerSite m)
                     , MonadCrypto m
                     , HasCryptoUUID plain m
                     , MonadCryptoKey m ~ CryptoIDKey
                     , KnownSymbol (CryptoIDNamespace UUID plain)
                     , Binary plain
-                    ) => plain -> MailT m MailObjectId
+                    ) => plain -> m MailObjectId
 setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid
 
 

src/Model/Migration.hs

@@ -189,6 +189,13 @@ customMigrations = Map.fromListWith (>>)
           ALTER TABLE "user" ADD COLUMN "authentication" json DEFAULT '"ldap"';
         |]
     )
+  , ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|]
+    , whenM (tableExists "user") $ do
+        [executeQQ|
+          ALTER TABLE "user" ADD COLUMN "notification_settings" json DEFAULT null;
+          UPDATE "user" SET "notification_settings" = (#{def :: NotificationSettings} :: json) WHERE "notification_settings" is null;
+        |]
+    )
   ]
 
 

src/Model/Types.hs

@@ -7,10 +7,14 @@
 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-- # LANGUAGE ExistentialQuantification #-} -- for DA type
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
 
-module Model.Types where
+module Model.Types
+  ( module Model.Types
+  , module Mail
+  ) where
 
 import ClassyPrelude
 import Utils
@@ -26,6 +30,8 @@ import Data.Universe
 import Data.Universe.Helpers
 import Data.UUID.Types
 
+import Data.Default
+
 import Text.Read (readMaybe)
 
 import Database.Persist.TH hiding (derivePersistFieldJSON)
@@ -40,20 +46,29 @@ import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Lens as Text
 
+import qualified Data.HashMap.Strict as HashMap
+
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 import Data.CaseInsensitive.Instances ()
 
 import Yesod.Core.Dispatch (PathPiece(..))
-import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..))
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value())
+import Data.Aeson.Types (toJSONKeyText)
 import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
 
 import GHC.Generics (Generic)
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 import Data.Typeable (Typeable)
 
+import Data.Universe.Instances.Reverse ()
+
 import qualified Yesod.Auth.Util.PasswordStore as PWStore
 
+import Mail (MailLanguages(..))
+
 
 instance PathPiece UUID where
   fromPathPiece = Data.UUID.Types.fromString . unpack
@@ -332,7 +347,7 @@ instance PathPiece TermIdentifier where
   toPathPiece = termToText
 
 instance ToJSON TermIdentifier where
-  toJSON = String . termToText
+  toJSON = Aeson.String . termToText
 
 instance FromJSON TermIdentifier where
   parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
@@ -443,13 +458,48 @@ derivePersistFieldJSON ''AuthenticationMode
 derivePersistFieldJSON ''Value
 
 
-data NotificationSettings = NotificationSettings
+-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
-  {
+--
-  } deriving (Eq, Ord, Read, Show)
+-- Could maybe be replaced with `Structure Notification` in the long term
+data NotificationTrigger = NTSubmissionRatedGraded
+                         | NTSubmissionRated
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+
+instance Universe NotificationTrigger
+instance Finite NotificationTrigger
+
+instance Hashable NotificationTrigger
 
 deriveJSON defaultOptions
-  { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-  } ''NotificationSettings
+  } ''NotificationTrigger
+
+instance ToJSONKey NotificationTrigger where
+  toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
+
+instance FromJSONKey NotificationTrigger where
+  fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
+
+
+newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool }
+  deriving (Generic, Typeable)
+  deriving newtype (Eq, Ord, Read, Show)
+
+instance Default NotificationSettings where
+  def = NotificationSettings $ \case
+    NTSubmissionRatedGraded -> True
+    NTSubmissionRated -> False
+
+instance ToJSON NotificationSettings where
+  toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF
+
+instance FromJSON NotificationSettings where
+  parseJSON = withObject "NotificationSettings" $ \o -> do
+    o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool)
+    return . NotificationSettings $ \n -> case HashMap.lookup n o' of
+      Nothing -> notificationAllowed def n
+      Just b  -> b
+
 derivePersistFieldJSON ''NotificationSettings
 
 
@@ -457,6 +507,9 @@ instance ToBackendKey SqlBackend record => Hashable (Key record) where
   hashWithSalt s key = s `hashWithSalt` fromSqlKey key
 
 
+derivePersistFieldJSON ''MailLanguages
+
+
 -- Type synonyms
 
 type Email           = Text

templates/mail/submissionRated.hamlet

@@ -0,0 +1,4 @@
+<html>
+  <body>
+    <h1>
+      _{MsgMailSubmissionRatedIntro (CI.original courseName) termDesc}

templates/mail/submissionRated.txt

@@ -0,0 +1 @@
+#{mr (MsgMailSubmissionRatedIntro (CI.original courseName) termDesc)}