From f98939885b20bc230391abd5a1921220d7ec72d1 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 11 Oct 2018 21:44:58 +0200 Subject: [PATCH] Wire in NotificationSubmissionRated --- db.hs | 5 ++ messages/uniworx/de.msg | 5 +- models | 4 +- package.yaml | 1 + src/Foundation.hs | 14 +-- src/Handler/Admin.hs | 9 +- src/Handler/Corrections.hs | 19 +++- src/Handler/Submission.hs | 4 +- src/Handler/Utils.hs | 1 + src/Handler/Utils/Mail.hs | 64 ++++++++++++++ src/Handler/Utils/Submission.hs | 42 +++++---- src/Jobs.hs | 113 ++++++++++++++++------- src/Jobs/Types.hs | 1 + src/Mail.hs | 123 +++++++++++++++++++------- src/Model/Migration.hs | 7 ++ src/Model/Types.hs | 69 +++++++++++++-- templates/mail/submissionRated.hamlet | 4 + templates/mail/submissionRated.txt | 1 + 18 files changed, 382 insertions(+), 104 deletions(-) create mode 100644 src/Handler/Utils/Mail.hs create mode 100644 templates/mail/submissionRated.hamlet create mode 100644 templates/mail/submissionRated.txt diff --git a/db.hs b/db.hs index 71128a7ff..3aa4fded0 100755 --- a/db.hs +++ b/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 diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index d4559a612..5cb71f00b 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -316,4 +316,7 @@ MailTestSubject: Uni2Work Test-Email MailTestContent: Dies ist eine Test-Email versandt von Uni2Work. Von Ihrer Seite ist keine Handlung notwendig. German: Deutsch -GermanGermany: Deutsch (Deutschland) \ No newline at end of file +GermanGermany: Deutsch (Deutschland) + +MailSubjectSubmissionRated csh@CourseShorthand: Ihre #{csh}-Abgabe wurde bewertet +MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{courseName} (#{termDesc}) wurde bewertet. \ No newline at end of file diff --git a/models b/models index d5b82b764..048b2876c 100644 --- a/models +++ b/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 @@ -227,4 +229,4 @@ QueuedJob creationTime UTCTime lockInstance InstanceId Maybe lockTime UTCTime Maybe - deriving Eq Read Show Generic Typeable + deriving Eq Read Show Generic Typeable \ No newline at end of file diff --git a/package.yaml b/package.yaml index 9c28d567d..3fce97630 100644 --- a/package.yaml +++ b/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. diff --git a/src/Foundation.hs b/src/Foundation.hs index b47168790..fe678c169 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1255,12 +1255,14 @@ instance YesodAuth UniWorX where let newUser = User - { userMaxFavourites = userDefaultMaxFavourites - , userTheme = userDefaultTheme - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles + { userMaxFavourites = userDefaultMaxFavourites + , userTheme = userDefaultTheme + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userNotificationSettings = def + , userMailLanguages = def , .. } userUpdate = [ UserMatrikelnummer =. userMatrikelnummer diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index f73d95348..bb21c60d0 100644 --- a/src/Handler/Admin.hs +++ b/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 - (fromSqlKey -> jId) <- queueJob $ JobSendTestEmail email ls - addMessage Success [shamlet|Email-test gestartet (Job ##{tshow jId})|] + (FormSuccess (email, ls)) -> do + jId <- runDB $ do + 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 diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 94aab5738..5cbe19078 100644 --- a/src/Handler/Corrections.hs +++ b/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 diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index b64be4126..30c56d2c3 100644 --- a/src/Handler/Submission.hs +++ b/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 - -> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False + (Just files, _) -> -- new files + 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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 394359b27..1b3d68334 100644 --- a/src/Handler/Utils.hs +++ b/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 diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs new file mode 100644 index 000000000..9196e8816 --- /dev/null +++ b/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 diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 32b9e4d65..a09e43ed2 100644 --- a/src/Handler/Utils/Submission.hs +++ b/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 - False -> insert_ $ SubmissionEdit userId now submissionId - True -> update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ] - -- TODO: Should submissionRatingAssigned change here if userId changes? + case isUpdate of + False -> lift . insert_ $ SubmissionEdit userId now submissionId + True -> do + 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)) $ - update submissionId + if + | 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) diff --git a/src/Jobs.hs b/src/Jobs.hs index d8ddd088e..52f596fae 100644 --- a/src/Jobs.hs +++ b/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) $ - runDB $ delete jId + -- `performJob` is expected to throw a notification if it detects that the job was not done + 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 -queueJob job = do - jId <- setSerializable $ do - now <- liftIO getCurrentTime - self <- getsYesod appInstanceID - insert QueuedJob - { queuedJobContent = toJSON job - , queuedJobCreationInstance = self - , queuedJobCreationTime = now - , queuedJobLockInstance = Nothing - , queuedJobLockTime = Nothing - } - writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something) - return jId +queueJobUnsafe :: Job -> YesodDB UniWorX QueuedJobId +queueJobUnsafe job = do + now <- liftIO getCurrentTime + self <- getsYesod appInstanceID + insert QueuedJob + { queuedJobContent = toJSON job + , queuedJobCreationInstance = self + , queuedJobCreationTime = now + , queuedJobLockInstance = 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) + -- 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 - transactionSave - [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] - act <* transactionSave +setSerializable = ([executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *>) -performJob :: Job -> WriterT (Last Bool) (HandlerT UniWorX IO) () -performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, .. } = do - $logDebugS "Jobs" "NotificationSubmissionRated" - fail "NotificationSubmissionRated not implemented yet" -- TODO -performJob JobSendTestEmail{..} = do - $logInfoS "Jobs" $ "Sending test-email to " <> jEmail - mailT jLanguages $ do - _mailTo .= [Address Nothing jEmail] - setSubjectI MsgMailTestSubject - addPart $ \(MsgRenderer mr) -> mr MsgMailTestContent +performJob :: Job -> HandlerT UniWorX IO () +performJob JobQueueNotification{ jNotification = n@NotificationSubmissionRated{..} } = do + jIds <- runDB . setSerializable $ do + Submission{submissionSheet} <- getJust nSubmission + isGraded <- (/= NotGraded) . sheetType <$> getJust submissionSheet + res <- E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do + E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission + return (user E.^. UserId, user E.^. UserNotificationSettings) + 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 diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 15a3764e8..db052c52d 100644 --- a/src/Jobs/Types.hs +++ b/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) diff --git a/src/Mail.hs b/src/Mail.hs index dec3ff823..d1c0e4e01 100644 --- a/src/Mail.hs +++ b/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 - , HandlerSite m ~ site - , RenderMessage site msg - ) => m (msg -> Text) -getMessageRender = renderMessage <$> getYesod <*> (mailLanguages <$> askMailLanguages) +getMailMessageRender :: ( MonadMail m + , HandlerSite m ~ site + , RenderMessage site msg + ) => m (msg -> Text) +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 + + + #{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 - toMailPart :: (MonadHandler m, HandlerSite m ~ site) => a -> StateT Part m () +class YesodMail site => ToMailPart site a where + 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 () -addAlternatives provided = MailT $ do + -> m () +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 part = MailT $ do - part' <- lift $ execStateT (toMailPart part) initialPart +addPart :: ( MonadMail m + , HandlerSite m ~ site + , 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 diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 54ec40156..bd6be6098 100644 --- a/src/Model/Migration.hs +++ b/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; + |] + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index c96fc0989..ecc10e1e4 100644 --- a/src/Model/Types.hs +++ b/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 - { - } deriving (Eq, Ord, Read, Show) +-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@ +-- +-- 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 - } ''NotificationSettings + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } ''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 diff --git a/templates/mail/submissionRated.hamlet b/templates/mail/submissionRated.hamlet new file mode 100644 index 000000000..a77616eaa --- /dev/null +++ b/templates/mail/submissionRated.hamlet @@ -0,0 +1,4 @@ +<html> + <body> + <h1> + _{MsgMailSubmissionRatedIntro (CI.original courseName) termDesc} diff --git a/templates/mail/submissionRated.txt b/templates/mail/submissionRated.txt new file mode 100644 index 000000000..1fa13f16f --- /dev/null +++ b/templates/mail/submissionRated.txt @@ -0,0 +1 @@ +#{mr (MsgMailSubmissionRatedIntro (CI.original courseName) termDesc)}