From ff5bb973835892f5d41f243079977e625803040e Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Tue, 20 Mar 2018 16:01:33 +0000 Subject: [PATCH] Move Yesod.Mail.Send to a new dedicated separate library --- src/Yesod/Mail/Send.hs | 234 ----------------------------------------- stack.yaml | 1 + vervis.cabal | 2 +- 3 files changed, 2 insertions(+), 235 deletions(-) delete mode 100644 src/Yesod/Mail/Send.hs diff --git a/src/Yesod/Mail/Send.hs b/src/Yesod/Mail/Send.hs deleted file mode 100644 index 8ddd65b..0000000 --- a/src/Yesod/Mail/Send.hs +++ /dev/null @@ -1,234 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2018 by fr33domlover . - - - - ♡ Copying is an act of love. Please copy, reuse and share. - - - - The author(s) have dedicated all copyright and related and neighboring - - rights to this software to the public domain worldwide. This software is - - distributed without any warranty. - - - - You should have received a copy of the CC0 Public Domain Dedication along - - with this software. If not, see - - . - -} - --- | This modules provides email support for Yesod apps. It allows handler code --- to send email messages, synchronously (i.e. instantly in the same thread) --- and asynchronously (i.e. pass the work to a separate thread, so that the --- user can have their HTTP response without waiting for the mail to be sent). --- --- Since the module is based on my own usage, some simple things aren't --- provided, but can be trivially provided if someone needs them (or when I get --- to the task of adding them regardless, whichever happens first): --- --- * Only plain text email is supported, but HTML email support is trivial to --- add if someone needs it --- * Only a single recipient is taken per message, but it's trivial to support --- taking a list of recipients --- * The mail is sent via an SMTP server using the @smtp-mail@ package. However --- it's easy to add flexibility to choose some other method. For example --- sending via the sendmail executable (package @mime-mail@), or sending via --- the Amazon SES server (package @mime-mail-ses@). -module Yesod.Mail.Send - ( YesodMailSend (..) - , MailSettings () - , MailRecipe () - , Address (..) - , sendMail - , submitMail - , runMailer - ) -where - -import Prelude - -import Control.Concurrent.Chan (writeChan) -import Control.Monad (forever) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Logger -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask) -import Data.Aeson -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) -import Database.Persist.Sql (LogFunc) -import Network.Mail.Mime (Mail, simpleMail') -import Network.Mail.SMTP hiding (Address (..), sendMail) -import Network.Socket (HostName, PortNumber) -import Text.Email.Validate (EmailAddress, validate) -import Text.Shakespeare.Text (TextUrl, renderTextUrl) -import Yesod.Core (Route, Yesod) -import Yesod.Core.Handler (HandlerT {-HandlerFor-}, getsYesod, getUrlRenderParams) - -import qualified Network.Mail.Mime as M (Address (..)) - -import Text.Email.Local - -type HandlerFor site = HandlerT site IO - -class Yesod site => YesodMailSend site where - - -- | - data MailMessage site - - -- | - formatMailMessage - :: Bool - -> Maybe Text - -> MailMessage site - -> (Text, TextUrl (Route site)) - - -- | - getMailSettings - :: HandlerFor site (Maybe MailSettings) - - -- | - getSubmitMail - :: HandlerFor site (Maybe (MailRecipe site -> HandlerFor site ())) - -data SmtpLogin = SmtpLogin - { smtpUser :: String - , smtpPassword :: String - } - -instance FromJSON SmtpLogin where - parseJSON = withObject "SmtpLogin" $ \ o -> - SmtpLogin - <$> o .: "user" - <*> o .: "password" - -data SmtpSettings = SmtpSettings - { smtpLogin :: Maybe SmtpLogin - , smtpHost :: HostName - , smtpPort :: PortNumber - } - -instance FromJSON SmtpSettings where - parseJSON = withObject "SmtpSettings" $ \ o -> - SmtpSettings - <$> o .:? "login" - <*> o .: "host" - <*> (fromInteger <$> o .: "port") - -data EmailAddress' = EmailAddress' { toEmailAddress :: EmailAddress } - -instance FromJSON EmailAddress' where - parseJSON = withText "EmailAddress" $ \ t -> - case validate $ encodeUtf8 t of - Left err -> fail $ "Parsing email address failed: " ++ err - Right email -> return $ EmailAddress' email - -data Address = Address - { addressName :: Maybe Text - , addressEmail :: EmailAddress - } - -data Address' = Address' { toAddress :: Address } - -instance FromJSON Address' where - parseJSON = withObject "Address" $ \ o -> fmap Address' $ - Address - <$> o .:? "name" - <*> (toEmailAddress <$> o .: "email") - -data MailSettings = MailSettings - { mailSmtp :: SmtpSettings - , mailSender :: Address - , mailAllowReply :: Bool - } - -instance FromJSON MailSettings where - parseJSON = withObject "MailSettings" $ \ o -> - MailSettings - <$> o .: "smtp" - <*> (toAddress <$> o .: "sender") - <*> o .: "allow-reply" - --- | This is exported from 'Text.Shakespeare' but the docs there say it's an --- internal module that will be hidden on the next release. So I prefer not to --- rely on it and define this type here. -type RenderUrl url = url -> [(Text, Text)] -> Text - -data MailRecipe site = MailRecipe - { mailUrlRender :: RenderUrl (Route site) - , mailRecipient :: Address - , mailMessage :: MailMessage site - } - -type Mailer = LoggingT IO ---type Mailer = LoggingT (ReaderT ConnectionPool IO) ---type MailerDB = SqlPersistT Mailer - -src :: Text -src = "Mail" - -{- -runMailerDB :: MailerDB a -> Mailer a -runMailerDB action = do - pool <- lift ask - runSqlPool action pool --} - -renderMessage - :: YesodMailSend site => Address -> Bool -> MailRecipe site -> Mail -renderMessage from reply (MailRecipe render to msg) = - let (subject, mkbody) = formatMailMessage reply (addressName to) msg - conv (Address n e) = M.Address n $ emailText e - in simpleMail' (conv to) (conv from) subject $ renderTextUrl render mkbody - -smtp :: SmtpSettings -> Mail -> IO () -smtp (SmtpSettings mlogin host port) = - case mlogin of - Nothing -> sendMail' host port - Just (SmtpLogin user pass) -> sendMailWithLogin' host port user pass - -send :: YesodMailSend site => MailSettings -> MailRecipe site -> IO () -send (MailSettings s a r) = smtp s . renderMessage a r - --- | Send an email message through an SMTP server and return once it's sent. --- Returns 'True' if sent, 'False' if email is disabled in settings. -sendMail - :: YesodMailSend site - => Address - -> MailMessage site - -> HandlerFor site Bool -sendMail recip msg = do - msettings <- getMailSettings - case msettings of - Nothing -> return False - Just settings -> do - urp <- getUrlRenderParams - let recipe = MailRecipe urp recip msg - liftIO $ send settings recipe >> return True - --- | Submit an email message into the queue for delivery through an SMTP --- server, and return without waiting for it to be sent. Returns 'True' if --- submitted, 'False' if email is disabled in settings. -submitMail - :: YesodMailSend site - => Address - -> MailMessage site - -> HandlerFor site Bool -submitMail recip msg = do - msubmit <- getSubmitMail - case msubmit of - Nothing -> return False - Just submit -> do - urp <- getUrlRenderParams - let recipe = MailRecipe urp recip msg - submit recipe >> return True - --- | Run mailer loop which reads messages from a queue and sends them to SMTP --- server. -runMailer - :: YesodMailSend site - => MailSettings -- ^ Details of SMTP server and email formatting --- -> ConnectionPool -- ^ DB connection pool for DB access - -> LogFunc -- ^ What to do with log messages - -> IO (MailRecipe site) -- ^ IO action that reads a message for sending - -> IO () -runMailer settings {-pool-} logFunc readMail = - flip {-runReaderT pool $ flip-} runLoggingT logFunc $ do - $logInfoS src "Mailer component starting" - forever $ liftIO $ readMail >>= send settings diff --git a/stack.yaml b/stack.yaml index c2b5b7a..9e42870 100644 --- a/stack.yaml +++ b/stack.yaml @@ -19,6 +19,7 @@ packages: git: https://dev.seek-together.space/s/fr33domlover/r/yesod-auth-account commit: 1bd49ddf91521bbfeb811af430d0e6918276d127 extra-dep: true + - '../yesod-mail-send' # Packages to be pulled from upstream that are not in the resolver (e.g., # acme-missiles-0.3) diff --git a/vervis.cabal b/vervis.cabal index 0e2ce90..4e8dcfb 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -101,7 +101,6 @@ library Yesod.Auth.Unverified Yesod.Auth.Unverified.Creds Yesod.Auth.Unverified.Internal - Yesod.Mail.Send Yesod.Paginate.Local Yesod.SessionEntity @@ -316,6 +315,7 @@ library , yesod-auth-account , yesod-core , yesod-form + , yesod-mail-send , yesod-static , yesod-persistent -- for reading gzipped darcs inventory via utils in