chore(mail): towards #2979 by providing simple mail resent function

src/Handler/MailCenter.hs

@@ -19,7 +19,7 @@ import qualified Data.Map as Map
 -- import qualified Data.Text as Text
 
 -- import Database.Persist.Sql (updateWhereCount)
--- import           Database.Esqueleto.Experimental ((:&)(..))
+import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
 import qualified Database.Esqueleto.Experimental as E
 import qualified Database.Esqueleto.Utils as E
@@ -53,6 +53,24 @@ data MCTableActionData  = MCActDummyData
   deriving (Eq, Ord, Read, Show, Generic)
 
 
+resendMailTo :: (MonoFoldable mono, Element mono ~ SentMailId) => UserEmail -> mono -> Handler ()
+resendMailTo recv smids = do
+  mails <- runDBRead $ E.select $ do
+    (sm :& smc) <- E.from $ E.table @SentMail `E.innerJoin` E.table @SentMailContent `E.on` (\(sm :& smc) -> sm E.^. SentMailContentRef E.==. smc E.^. SentMailContentId)
+    E.where_ $ sm E.^. SentMailId `E.in_` E.vals smids
+    return (sm, smc)
+  -- recvName <- fmap userDisplayName $ getByFilter $ [UserEmail ==. recv] ||. [UserDisplayEmail ==. rev]
+  forM_ mails $ \(Entity {entityVal=SentMail{..}}, Entity{entityVal=SentMailContent{sentMailContentContent=content}}) -> do
+    let mailParts = getMailContent content
+        mailTo    = [Address{addressName = Nothing, addressEmail = ciOriginal recv}]
+        mailCc    = []
+        mailBcc   = []
+        mailFrom  = error "not used"  -- :: Address
+        -- continue here: delete some weird outdated headers
+        mailHeaders = toHeaders sentMailHeaders -- :: Headers
+    sendSimpleMail Mail{..}
+
+
 type MCTableExpr =
   (                   E.SqlExpr (Entity SentMail)
     `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))

src/Mail.hs

@@ -40,6 +40,7 @@ module Mail
   , _addressName, _addressEmail
   , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailReplyTo', _mailHeaders, _mailHeader, _mailHeader', _mailParts
   , _partType, _partEncoding, _partDisposition, _partFilename, _partHeaders, _partContent
+  , sendSimpleMail
   ) where
 
 import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON)
@@ -136,6 +137,9 @@ import Data.Text.Lazy.Encoding (decodeUtf8')
 import System.FilePath (takeFileName)
 import Network.HTTP.Types.Header (hETag)
 import Web.HttpApiData (ToHttpApiData(toHeader))
+import Data.Containers.ListUtils
+
+{-# ANN module ("HLint: ignore Parenthesize unary negation" :: String) #-}
 
 
 newtype AddressEqIgnoreName = AddressEqIgnoreName { getAddress :: Address }
@@ -371,6 +375,23 @@ defMailT ls (MailT mailC) = do
         mail3
         conn
 
+sendSimpleMail :: ( MonadHandler m
+                  , YesodMail (HandlerSite m)
+                  , MonadUnliftIO m
+                  , MonadThrow m
+                  ) => Mail -> m ()
+sendSimpleMail eml = do
+  fromAddress <- defaultFromAddress
+  returnPath <- unpack <$> envelopeFromAddress
+  let recipients = nubOrd $ map (unpack . addressEmail) $ mailTo eml ++ mailCc eml ++ mailBcc eml
+  content <- liftIO $ LBS.toStrict <$> renderMail' eml{mailFrom = fromAddress}
+  mailSmtp $ \conn -> do
+    liftIO $ SMTP.sendMail
+      returnPath
+      recipients
+      content
+      conn
+
 
 data PrioritisedAlternatives m = PrioritisedAlternatives
   { preferredAlternative :: Last (m Part)