diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs index 4c5666cde..70792a07d 100644 --- a/src/Handler/MailCenter.hs +++ b/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)) diff --git a/src/Mail.hs b/src/Mail.hs index cb44ce38e..61eeab90c 100644 --- a/src/Mail.hs +++ b/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)