diff --git a/IHP/Mail.hs b/IHP/Mail.hs new file mode 100644 --- /dev/null +++ b/IHP/Mail.hs @@ -0,0 +1,163 @@ +{-| +Module: IHP.Mail +Description: Send Emails +Copyright: (c) digitally induced GmbH, 2020 +-} +module IHP.Mail +( MailServer (..) +, BuildMail (..) +, SMTPEncryption (..) +, sendMail +, sendWithMailServer +) +where + +import IHP.Prelude +import IHP.Mail.Types +import IHP.FrameworkConfig + +import Network.Mail.Mime +import qualified Network.Mail.Mime.SES as Mailer +import qualified Network.Mail.SMTP as SMTP +import qualified Network.HTTP.Client +import qualified Network.HTTP.Client.TLS +import Text.Blaze.Html5 (Html) +import qualified Text.Blaze.Html.Renderer.Text as Blaze +import qualified Data.Text as Text +import Data.Maybe +import qualified Data.TMap as TMap + +buildMail :: (BuildMail mail, ?context :: context, ConfigProvider context) => mail -> Mail +buildMail mail = + let ?mail = mail in + let mail' = simpleMailInMemory (to mail) from subject (cs $ text mail) (html mail |> Blaze.renderHtml) attachments' in + mail' { mailCc = cc mail + , mailBcc = bcc mail + , mailHeaders = ("Subject", subject) : h + } + where + h = case replyTo mail of + Nothing -> headers mail + Just replyTo -> ("Reply-To", renderAddress replyTo) : (headers mail) + + attachments' = mail + |> attachments + |> map (\MailAttachment { name, content, contentType } -> (contentType, name, content)) + +-- | Retrieves the mail server configuration from the framework config's appConfig TMap +-- +-- Returns an error if no mail server has been configured. Users must add +-- @option Sendmail@ or similar to their Config.hs. +getMailServer :: (?context :: context, ConfigProvider context) => MailServer +getMailServer = ?context.frameworkConfig.appConfig + |> TMap.lookup @MailServer + |> fromMaybe (error "No mail server configured. Add 'option Sendmail' or similar to Config.hs") + +-- | Sends an email +-- +-- Uses the mail server provided via @option@ in Config.hs, stored in appConfig +sendMail :: (BuildMail mail, ?context :: context, ConfigProvider context) => mail -> IO () +sendMail mail = sendWithMailServer getMailServer (buildMail mail) + +sendWithMailServer :: MailServer -> Mail -> IO () +sendWithMailServer SES { .. } mail = do + manager <- Network.HTTP.Client.newManager Network.HTTP.Client.TLS.tlsManagerSettings + let ses = Mailer.SES { + Mailer.sesFrom = cs $ addressEmail (mailFrom mail), + Mailer.sesTo = map (cs . addressEmail) ((mailTo mail) <> (mailCc mail) <> (mailBcc mail)), + Mailer.sesAccessKey = accessKey, + Mailer.sesSecretKey = secretKey, + Mailer.sesSessionToken = Nothing, + Mailer.sesRegion = region + } + Mailer.renderSendMailSES manager ses mail + +sendWithMailServer SendGrid { .. } mail = do + let mail' = if isJust category then mail {mailHeaders = ("X-SMTPAPI","{\"category\": \"" ++ (fromJust category) ++ "\"}") : headers} else mail + SMTP.sendMailWithLoginSTARTTLS' "smtp.sendgrid.net" 587 "apikey" (Text.unpack apiKey) mail' + where headers = mailHeaders mail + +sendWithMailServer IHP.Mail.Types.SMTP { .. } mail + | isNothing credentials = + case encryption of + Unencrypted -> SMTP.sendMail' host port mail + TLS -> SMTP.sendMailTLS' host port mail + STARTTLS -> SMTP.sendMailSTARTTLS' host port mail + | otherwise = + case encryption of + Unencrypted -> SMTP.sendMailWithLogin' host port (fst creds) (snd creds) mail + TLS -> SMTP.sendMailWithLoginTLS' host port (fst creds) (snd creds) mail + STARTTLS -> SMTP.sendMailWithLoginSTARTTLS' host port (fst creds) (snd creds) mail + where creds = fromJust credentials + +sendWithMailServer Sendmail mail = do + message <- renderMail' mail + sendmail message + +class BuildMail mail where + -- | You can use @?mail@ to make this dynamic based on the given entity + subject :: (?mail :: mail) => Text + + -- | The email receiver + -- + -- __Example:__ + -- + -- > to ConfirmationMail { .. } = Address { addressName = Just (user.name), addressEmail = user.email } + -- + -- __Example:__ Send all emails to a fixed email address while in development mode + -- + -- > to CreateAccountMail { .. } = Address + -- > { addressName = Just (fullName admin) + -- > , addressEmail = + -- > if isDevelopment then + -- > "staging@example.com" + -- > else + -- > admin.email + -- > } + -- + to :: (?context :: context, ConfigProvider context) => mail -> Address + + -- | Sets an optional reply-to address + replyTo :: (?context :: context, ConfigProvider context) => mail -> Maybe Address + replyTo mail = Nothing + + -- | Public list of addresses to receive a copy of the mail (CC) + cc :: (?context :: context, ConfigProvider context) => mail -> [Address] + cc mail = [] + + -- | Hidden list of addresses to receive a copy of the mail (BCC) + bcc :: (?context :: context, ConfigProvider context) => mail -> [Address] + bcc mail = [] + + -- | Custom headers, excluding @from@, @to@, @cc@, @bcc@, @subject@, and @reply-to@ + -- + -- __Example:__ Add a custom X-Mailer header + -- + -- > headers CreateAccountMail { .. } = [("X-Mailer", "mail4j 2.17.0")] + -- + headers :: (?context :: context, ConfigProvider context) => mail -> Headers + headers mail = [] + + -- | Your sender address + -- + -- __Example:__ + -- + -- > from = Address { addressName = "Acme Inc.", addressEmail = "hi@example.com" } + -- + from :: (?mail :: mail, ?context :: context, ConfigProvider context) => Address + + -- | Similiar to a normal html view, HSX can be used here + html :: (?context :: context, ConfigProvider context) => mail -> Html + + -- | When no plain text version of the email is specified it falls back to using the html version but striping out all the html tags + text :: (?context :: context, ConfigProvider context) => mail -> Text + text mail = stripTags (cs $ Blaze.renderHtml (html mail)) + + -- | Optional, mail attachments + -- + -- __Example:__ + -- + -- > attachments = [ MailAttachment { name = "attached_file.xml", contentType = "application/xml", content = "" } ] + -- + attachments :: (?context :: context, ConfigProvider context) => mail -> [MailAttachment] + attachments mail = [] diff --git a/IHP/Mail/Types.hs b/IHP/Mail/Types.hs new file mode 100644 --- /dev/null +++ b/IHP/Mail/Types.hs @@ -0,0 +1,49 @@ +{-| +Module: IHP.Mail.Types +Description: Types for emails +Copyright: (c) digitally induced GmbH, 2020 +-} +module IHP.Mail.Types +( MailServer (..) +, MailAttachment (..) +, SMTPEncryption (..) +) +where + +import IHP.Prelude +import IHP.EnvVar +import Network.Socket (PortNumber) + +-- | Configuration for a mailer used by IHP +data SMTPEncryption = Unencrypted | TLS | STARTTLS + +data MailServer = + -- | Uses AWS SES for sending emails + SES { accessKey :: ByteString + , secretKey :: ByteString + -- | E.g. @"us-east-1"@ or @"eu-west-1"@ + , region :: Text } + -- | Uses the local Sendmail binary for sending emails + | Sendmail + -- | Uses SendGrid for sending emails + | SendGrid { apiKey :: Text + , category :: Maybe Text } + -- | Uses a generic SMTP server for sending emails + | SMTP { host :: String + , port :: PortNumber + -- (Username,Password) combination + , credentials :: Maybe (String, String) + , encryption :: SMTPEncryption } + +data MailAttachment = MailAttachment + { name :: Text -- ^ File name of an attachment + , content :: LByteString + , contentType :: Text + } deriving (Eq, Show) + +-- | Allow reading SMTP encryption settings from environment variables +instance EnvVarReader SMTPEncryption where + envStringToValue "Unencrypted" = Right Unencrypted + envStringToValue "TLS" = Right TLS + envStringToValue "STARTTLS" = Right STARTTLS + envStringToValue _ = Left "Should be set to 'Unencrypted', 'TLS', or 'STARTTLS'" diff --git a/IHP/MailPrelude.hs b/IHP/MailPrelude.hs new file mode 100644 --- /dev/null +++ b/IHP/MailPrelude.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_HADDOCK not-home, hide #-} +{-| +Module: IHP.MailPrelude +Description: Prelude for email views +Copyright: (c) digitally induced GmbH, 2020 +-} +module IHP.MailPrelude +( module IHP.Mail +, module Network.Mail.Mime +, module IHP.ViewPrelude +, module IHP.Mail.Types +) where + +import IHP.Mail +import IHP.Mail.Types +import Network.Mail.Mime +import IHP.ViewPrelude hiding (html) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2020 digitally induced GmbH + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,9 @@ +# Changelog for `ihp-mail` + +## v1.5.0 + +- Add `EnvVarReader` instance for `SMTPEncryption` + +## v1.4.0 + +- Initial release as a standalone package, extracted from ihp diff --git a/ihp-mail.cabal b/ihp-mail.cabal new file mode 100644 --- /dev/null +++ b/ihp-mail.cabal @@ -0,0 +1,66 @@ +cabal-version: 2.2 +name: ihp-mail +version: 1.5.0 +synopsis: Email support for IHP +description: Provides email sending functionality for IHP applications +license: MIT +license-file: LICENSE +author: digitally induced GmbH +maintainer: hello@digitallyinduced.com +homepage: https://ihp.digitallyinduced.com/ +bug-reports: https://github.com/digitallyinduced/ihp/issues +copyright: (c) digitally induced GmbH +category: Web, IHP +stability: Stable +build-type: Simple +extra-source-files: changelog.md + +source-repository head + type: git + location: https://github.com/digitallyinduced/ihp + +common shared-properties + default-language: GHC2021 + default-extensions: + OverloadedStrings + , NoImplicitPrelude + , ImplicitParams + , DisambiguateRecordFields + , DuplicateRecordFields + , OverloadedLabels + , DataKinds + , QuasiQuotes + , TypeFamilies + , PackageImports + , RecordWildCards + , DefaultSignatures + , FunctionalDependencies + , PartialTypeSignatures + , BlockArguments + , LambdaCase + , TemplateHaskell + , OverloadedRecordDot + , DeepSubsumption + ghc-options: -Werror=incomplete-patterns -Werror=unused-imports -Werror=missing-fields + +library + import: shared-properties + hs-source-dirs: . + exposed-modules: + IHP.Mail + , IHP.Mail.Types + , IHP.MailPrelude + build-depends: + base >= 4.17.0 && < 4.22 + , ihp + , mime-mail + , mime-mail-ses + , smtp-mail + , http-client + , http-client-tls + , blaze-html + , text + , bytestring + , network + , string-conversions + , typerep-map