Move Yesod.Mail.Send to a new dedicated separate library

src/Yesod/Mail/Send.hs

@@ -1,234 +0,0 @@
-{- This file is part of Vervis.
- -
- - Written in 2018 by fr33domlover <fr33domlover@riseup.net>.
- -
- - ♡ 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
- - <http://creativecommons.org/publicdomain/zero/1.0/>.
- -}
-
--- | 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

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)

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