From 9da61c10b53316a97928ad35f951416410750163 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 17 Jan 2023 13:34:37 +0100 Subject: [PATCH] chore(mail): add setting to reroute all mails (letters are generated but not sent) --- src/Foundation/Instances.hs | 1 + src/Handler/Utils/Mail.hs | 2 +- src/Mail.hs | 25 ++++++++++++++++--------- src/Settings.hs | 2 ++ src/Utils.hs | 2 -- src/Utils/Print.hs | 37 ++++++++++++++++++++++--------------- 6 files changed, 42 insertions(+), 27 deletions(-) diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 23d97e918..5881af647 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -182,6 +182,7 @@ instance YesodMail UniWorX where envelopeFromAddress = getsYesod $ view _appMailEnvelopeFrom mailObjectIdDomain = getsYesod $ view _appMailObjectDomain useReplyToInstead = getsYesod $ view _appMailUseReplyToInstead + mailRerouteTo = getsYesod $ view _appMailRerouteTo mailDateTZ = return appTZ mailSmtp act = do pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index a79d0bce0..f585de16a 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -51,7 +51,7 @@ userAddress :: User -> Address userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userEmail --- |Send an email to the given UserId or to all registered Supervisor with rerouteNotifications == True +-- | Send an email to the given UserId or to all registered Supervisor with rerouteNotifications == True userMailT :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadThrow m diff --git a/src/Mail.hs b/src/Mail.hs index 8ef236a5f..1df563faf 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -78,7 +78,7 @@ import qualified Data.Text.Lazy.Builder as LTB import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString as BS -import Utils (MsgRendererS(..), MonadSecretBox(..), YamlValue, maybeMonoid, insertAssoc, maybeT, guardM, adjustAssoc) +import Utils (MsgRendererS(..), MonadSecretBox(..), YamlValue, maybeMonoid, insertAssoc, maybeM, maybeT, guardM, adjustAssoc) import Utils.Lens.TH import Control.Lens hiding (from) @@ -272,6 +272,9 @@ class Yesod site => YesodMail site where useReplyToInstead :: (MonadHandler m, HandlerSite m ~ site) => m Bool useReplyToInstead = return True -- not changeing the sender is the save choice + mailRerouteTo :: (MonadHandler m, HandlerSite m ~ site) => m (Maybe Address) + mailRerouteTo = return Nothing -- all mail will be sent to this address instead, if set (for test-instances) + mailDateTZ :: (MonadHandler m, HandlerSite m ~ site) => m TZ mailDateTZ = return utcTZ @@ -325,19 +328,23 @@ defMailT :: ( MonadHandler m -> m a defMailT ls (MailT mailC) = do fromAddress <- defaultFromAddress - (ret, mail, smtpData) <- runRWST mailC ls (emptyMail fromAddress) - mail' <- maybeT (return mail) $ do + (ret, mail0, smtpData) <- runRWST mailC ls (emptyMail fromAddress) + mail1 <- maybeT (return mail0) $ do guardM useReplyToInstead -- if sender must be fixed within ObjectIdDomain, use replyTo instead domain <- mailObjectIdDomain - let sender = mail ^. _mailFrom + let sender = mail0 ^. _mailFrom isdomainaddress = (Text.isInfixOf `on` Text.toCaseFold) domain (sender ^. _addressEmail) -- not sure how to use CI.mk and isInfixOf here $logDebugS "Mail" $ "Use ReplyTo instead of Sender: " <> tshow isdomainaddress <> " From was: " <> renderAddress sender <> " From is: " <> renderAddress fromAddress guard isdomainaddress -- allowing foreign senders might be Fraport specific; maybe remove this guard - return $ mail + return $ mail0 & _mailFrom .~ fromAddress - & _mailReplyTo .~ sender - mail'' <- liftIO $ LBS.toStrict <$> renderMail' mail' - $logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail'' + & _mailReplyTo .~ sender + let switchRecipient rerouteTo = return $ mail1 + & _mailTo .~ [rerouteTo] + & Mime.addPart [plainPart $ LT.fromStrict $ "Due to setting 'mail-reroute-to', this mail was diverted; it would have been sent to: " <> tshow (mail1 ^. _mailTo)] + mail2 <- maybeM (return mail1) switchRecipient mailRerouteTo + mail3 <- liftIO $ LBS.toStrict <$> renderMail' mail2 + $logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail3 ret <$ case smtpData of MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified MailSmtpData{ smtpRecipients } @@ -349,7 +356,7 @@ defMailT ls (MailT mailC) = do liftIO $ SMTP.sendMail returnPath recipients - mail'' + mail3 conn diff --git a/src/Settings.hs b/src/Settings.hs index 1fe264ecd..3d7ab8d08 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -136,6 +136,7 @@ data AppSettings = AppSettings , appMailFrom , appMailSender , appMailSupport :: Address + , appMailRerouteTo :: Maybe Address , appMailUseReplyToInstead :: Bool , appJobWorkers :: Natural , appJobFlushInterval :: Maybe NominalDiffTime @@ -656,6 +657,7 @@ instance FromJSON AppSettings where appMailVerp <- fromMaybe VerpNone . join <$> (o .:? "mail-verp" <|> pure Nothing) appMailRetainSent <- o .: "mail-retain-sent" appMailSupport <- o .: "mail-support" + appMailRerouteTo <- o .:? "mail-reroute-to" appJobWorkers <- o .: "job-workers" appJobFlushInterval <- o .:? "job-flush-interval" diff --git a/src/Utils.hs b/src/Utils.hs index 9e9ccc445..418178de7 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -842,8 +842,6 @@ toNothingS = const Nothing -- null2nothing other = other -- | Swap 'Nothing' for 'Just' and vice versa --- This belongs into Module 'Utils' but we have a weird cyclic --- dependency flipMaybe :: b -> Maybe a -> Maybe b flipMaybe x Nothing = Just x flipMaybe _ (Just _) = Nothing diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index ca49bd596..4f6d018d2 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -412,7 +412,7 @@ instance MDLetter LetterRenewQualificationF where } sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool -sendEmailOrLetter recipient letter = do +sendEmailOrLetter recipient letter = do (underling, receivers, undercopy) <- runDB $ getReceivers recipient let tmpl = getTemplate $ pure letter pjid = getPJId letter @@ -453,7 +453,7 @@ sendEmailOrLetter recipient letter = do let msg = "Notification failed for " <> tshow encRecipient <> ". PDF generation failed: "<> cropText err <> "For Notification: " <> tshow pjid $logErrorS "LETTER" msg return False - Right pdf | preferPost -> -- send letter + Right pdf | preferPost -> -- send printed letter runDB (sendLetter pdf pjid{ pjiRecipient = Just svr}) >>= \case Left err -> do encRecipient :: CryptoUUIDUser <- encrypt svr @@ -557,21 +557,28 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read -- | Internal only, use `sendLetter` instead lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => Text -> LBS.ByteString -> m (Either Text Text) lprPDF jb bs = do - lprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg - let pc = setStdin (byteStringInput bs) $ - proc "lpr" $ - jobname ++ -- -J jobname -- a name for job identification at printing site - [ lprServerArg -- -P queue@hostname:port - , "-" -- read from stdin - ] - jobname | null jb = [] - | otherwise = ["-J " <> jb'] - jb' = T.unpack $ sanitizeCmdArg jb - exit2either <$> readProcess' pc + mbLprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg + case mbLprServerArg of + Nothing -> return $ Right "Print command ignored due to setting 'mail-reroute-to' being set." + Just lprServerArg -> do + let pc = setStdin (byteStringInput bs) $ + proc "lpr" $ + jobname ++ -- -J jobname -- a name for job identification at printing site + [ lprServerArg -- -P queue@hostname:port + , "-" -- read from stdin + ] + jobname | null jb = [] + | otherwise = ["-J " <> jb'] + jb' = T.unpack $ sanitizeCmdArg jb + exit2either <$> readProcess' pc where getLprServerArg = do - LprConf{..} <- getsYesod $ view _appLprConf - return $ "-P " <> lprQueue <> "@" <> lprHost <> ":" <> show lprPort + rerouteMail <- getsYesod $ view _appMailRerouteTo + case rerouteMail of + Just _ -> return Nothing + Nothing -> do + LprConf{..} <- getsYesod $ view _appLprConf + return . Just $ "-P " <> lprQueue <> "@" <> lprHost <> ":" <> show lprPort {- -- Variant without caching