chore(mail): add setting to reroute all mails (letters are generated but not sent)

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

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

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)  
+  (ret, mail0, smtpData) <- runRWST mailC ls (emptyMail fromAddress)  
-  mail' <- maybeT (return mail) $ do
+  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'
+  let switchRecipient rerouteTo = return $ mail1
-  $logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail''
+        & _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
 
 

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"

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

src/Utils/Print.hs

@@ -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
+    mbLprServerArg <- $cachedHereBinary ("lprServer"::Text) getLprServerArg
-    let pc = setStdin (byteStringInput bs) $
+    case mbLprServerArg of 
-              proc "lpr" $
+      Nothing -> return $ Right "Print command ignored due to setting 'mail-reroute-to' being set."
-                jobname ++                                      -- -J jobname -- a name for job identification at printing site
+      Just lprServerArg -> do 
-                [ lprServerArg                                  -- -P queue@hostname:port
+        let pc = setStdin (byteStringInput bs) $
-                , "-"                                           -- read from stdin
+                  proc "lpr" $
-                ]
+                    jobname ++                                      -- -J jobname -- a name for job identification at printing site
-        jobname | null jb   = []
+                    [ lprServerArg                                  -- -P queue@hostname:port
-                | otherwise = ["-J " <> jb']
+                    , "-"                                           -- read from stdin
-        jb' = T.unpack $ sanitizeCmdArg jb
+                    ]
-    exit2either <$> readProcess' pc
+            jobname | null jb   = []
+                    | otherwise = ["-J " <> jb']
+            jb' = T.unpack $ sanitizeCmdArg jb
+        exit2either <$> readProcess' pc
   where
     getLprServerArg = do
-      LprConf{..} <- getsYesod $ view _appLprConf
+      rerouteMail <- getsYesod $ view _appMailRerouteTo      
-      return $ "-P " <> lprQueue <> "@" <> lprHost <> ":" <> show lprPort
+      case rerouteMail of 
+        Just _  -> return Nothing
+        Nothing -> do 
+          LprConf{..} <- getsYesod $ view _appLprConf
+          return . Just $ "-P " <> lprQueue <> "@" <> lprHost <> ":" <> show lprPort
 
 
 {- -- Variant without caching