{-# LANGUAGE CPP, DeriveGeneric, OverloadedStrings, RecordWildCards #-}
module Network.Mail.Mime
    ( -- * Datatypes
      Boundary (..)
    , Mail (..)
    , emptyMail
    , Address (..)
    , Alternatives
    , Part (..)
    , PartContent (..)
    , Disposition (..)
    , Encoding (..)
    , InlineImage(..)
    , ImageContent(..)
    , Headers
      -- * Render a message
    , renderMail
    , renderMail'
      -- * Sending messages
    , sendmail
    , sendmailCustom
    , sendmailCustomCaptureOutput
    , renderSendMail
    , renderSendMailCustom
      -- * High-level 'Mail' creation
    , simpleMail
    , simpleMail'
    , simpleMailInMemory
    , simpleMailWithImages
      -- * Utilities
    , addPart
    , addAttachment
    , addAttachments
    , addAttachmentBS
    , addAttachmentsBS
    , renderAddress
    , htmlPart
    , plainPart
    , filePart
    , filePartBS
    , randomString
    , quotedPrintable
    , relatedPart
    , addImage
    , mkImageParts
    ) where

import qualified Data.ByteString.Lazy as L
import Blaze.ByteString.Builder.Char.Utf8
import Blaze.ByteString.Builder
import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar)
import Data.Monoid
import System.Random
import Control.Arrow
import System.Process
import System.IO
import System.Exit
import System.FilePath (takeFileName)
import qualified Data.ByteString.Base64 as Base64
import Control.Monad ((<=<), (>=>), foldM, void)
import Control.Exception (throwIO, ErrorCall (ErrorCall))
import Data.List (intersperse)
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import Data.ByteString.Char8 ()
import Data.Bits ((.&.), shiftR)
import Data.Char (isAscii, isControl)
import Data.Word (Word8)
import Data.String (IsString(..))
import qualified Data.ByteString as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import GHC.Generics (Generic)

-- | Generates a random sequence of alphanumerics of the given length.
randomString :: RandomGen d => Int -> d -> (String, d)
randomString :: Int -> d -> (String, d)
randomString Int
len =
    ([Int] -> String) -> ([Int], d) -> (String, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
forall p. Enum p => Int -> p
toChar) (([Int], d) -> (String, d))
-> (d -> ([Int], d)) -> d -> (String, d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [d -> (Int, d)] -> d -> ([Int], d)
forall b a. [b -> (a, b)] -> b -> ([a], b)
sequence' (Int -> (d -> (Int, d)) -> [d -> (Int, d)]
forall a. Int -> a -> [a]
replicate Int
len ((Int, Int) -> d -> (Int, d)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, Int
61)))
  where
    sequence' :: [b -> (a, b)] -> b -> ([a], b)
sequence' [] b
g = ([], b
g)
    sequence' (b -> (a, b)
f:[b -> (a, b)]
fs) b
g =
        let (a
f', b
g') = b -> (a, b)
f b
g
            ([a]
fs', b
g'') = [b -> (a, b)] -> b -> ([a], b)
sequence' [b -> (a, b)]
fs b
g'
         in (a
f' a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
fs', b
g'')
    toChar :: Int -> p
toChar Int
i
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
26 = Int -> p
forall p. Enum p => Int -> p
toEnum (Int -> p) -> Int -> p
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'A'
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
52 = Int -> p
forall p. Enum p => Int -> p
toEnum (Int -> p) -> Int -> p
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
26
        | Bool
otherwise = Int -> p
forall p. Enum p => Int -> p
toEnum (Int -> p) -> Int -> p
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'0' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
52

-- | MIME boundary between parts of a message.
newtype Boundary = Boundary { Boundary -> Text
unBoundary :: Text }
  deriving (Boundary -> Boundary -> Bool
(Boundary -> Boundary -> Bool)
-> (Boundary -> Boundary -> Bool) -> Eq Boundary
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Boundary -> Boundary -> Bool
$c/= :: Boundary -> Boundary -> Bool
== :: Boundary -> Boundary -> Bool
$c== :: Boundary -> Boundary -> Bool
Eq, Int -> Boundary -> ShowS
[Boundary] -> ShowS
Boundary -> String
(Int -> Boundary -> ShowS)
-> (Boundary -> String) -> ([Boundary] -> ShowS) -> Show Boundary
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Boundary] -> ShowS
$cshowList :: [Boundary] -> ShowS
show :: Boundary -> String
$cshow :: Boundary -> String
showsPrec :: Int -> Boundary -> ShowS
$cshowsPrec :: Int -> Boundary -> ShowS
Show)
instance Random Boundary where
    randomR :: (Boundary, Boundary) -> g -> (Boundary, g)
randomR = (g -> (Boundary, g)) -> (Boundary, Boundary) -> g -> (Boundary, g)
forall a b. a -> b -> a
const g -> (Boundary, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random
    random :: g -> (Boundary, g)
random = (String -> Boundary) -> (String, g) -> (Boundary, g)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Text -> Boundary
Boundary (Text -> Boundary) -> (String -> Text) -> String -> Boundary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) ((String, g) -> (Boundary, g))
-> (g -> (String, g)) -> g -> (Boundary, g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> g -> (String, g)
forall d. RandomGen d => Int -> d -> (String, d)
randomString Int
10

-- | An entire mail message.
data Mail = Mail
    { Mail -> Address
mailFrom :: Address
    , Mail -> [Address]
mailTo   :: [Address]
    , Mail -> [Address]
mailCc   :: [Address]
    , Mail -> [Address]
mailBcc  :: [Address]
    -- | Other headers, excluding from, to, cc and bcc.
    , Mail -> Headers
mailHeaders :: Headers
    -- | A list of different sets of alternatives. As a concrete example:
    --
    -- > mailParts = [ [textVersion, htmlVersion], [attachment1], [attachment1]]
    --
    -- Make sure when specifying alternatives to place the most preferred
    -- version last.
    , Mail -> [Alternatives]
mailParts :: [Alternatives]
    }
  deriving (Int -> Mail -> ShowS
[Mail] -> ShowS
Mail -> String
(Int -> Mail -> ShowS)
-> (Mail -> String) -> ([Mail] -> ShowS) -> Show Mail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mail] -> ShowS
$cshowList :: [Mail] -> ShowS
show :: Mail -> String
$cshow :: Mail -> String
showsPrec :: Int -> Mail -> ShowS
$cshowsPrec :: Int -> Mail -> ShowS
Show, (forall x. Mail -> Rep Mail x)
-> (forall x. Rep Mail x -> Mail) -> Generic Mail
forall x. Rep Mail x -> Mail
forall x. Mail -> Rep Mail x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Mail x -> Mail
$cfrom :: forall x. Mail -> Rep Mail x
Generic)

-- | A mail message with the provided 'from' address and no other
-- fields filled in.
emptyMail :: Address -> Mail
emptyMail :: Address -> Mail
emptyMail Address
from = Mail :: Address
-> [Address]
-> [Address]
-> [Address]
-> Headers
-> [Alternatives]
-> Mail
Mail
    { mailFrom :: Address
mailFrom    = Address
from
    , mailTo :: [Address]
mailTo      = []
    , mailCc :: [Address]
mailCc      = []
    , mailBcc :: [Address]
mailBcc     = []
    , mailHeaders :: Headers
mailHeaders = []
    , mailParts :: [Alternatives]
mailParts   = []
    }

data Address = Address
    { Address -> Maybe Text
addressName  :: Maybe Text
    , Address -> Text
addressEmail :: Text
    }
  deriving (Address -> Address -> Bool
(Address -> Address -> Bool)
-> (Address -> Address -> Bool) -> Eq Address
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Address -> Address -> Bool
$c/= :: Address -> Address -> Bool
== :: Address -> Address -> Bool
$c== :: Address -> Address -> Bool
Eq, Int -> Address -> ShowS
[Address] -> ShowS
Address -> String
(Int -> Address -> ShowS)
-> (Address -> String) -> ([Address] -> ShowS) -> Show Address
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Address] -> ShowS
$cshowList :: [Address] -> ShowS
show :: Address -> String
$cshow :: Address -> String
showsPrec :: Int -> Address -> ShowS
$cshowsPrec :: Int -> Address -> ShowS
Show, (forall x. Address -> Rep Address x)
-> (forall x. Rep Address x -> Address) -> Generic Address
forall x. Rep Address x -> Address
forall x. Address -> Rep Address x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Address x -> Address
$cfrom :: forall x. Address -> Rep Address x
Generic)

instance IsString Address where
    fromString :: String -> Address
fromString = Maybe Text -> Text -> Address
Address Maybe Text
forall a. Maybe a
Nothing (Text -> Address) -> (String -> Text) -> String -> Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
Data.String.fromString

-- | How to encode a single part. You should use 'Base64' for binary data.
data Encoding = None | Base64 | QuotedPrintableText | QuotedPrintableBinary
  deriving (Encoding -> Encoding -> Bool
(Encoding -> Encoding -> Bool)
-> (Encoding -> Encoding -> Bool) -> Eq Encoding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Encoding -> Encoding -> Bool
$c/= :: Encoding -> Encoding -> Bool
== :: Encoding -> Encoding -> Bool
$c== :: Encoding -> Encoding -> Bool
Eq, Int -> Encoding -> ShowS
[Encoding] -> ShowS
Encoding -> String
(Int -> Encoding -> ShowS)
-> (Encoding -> String) -> ([Encoding] -> ShowS) -> Show Encoding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Encoding] -> ShowS
$cshowList :: [Encoding] -> ShowS
show :: Encoding -> String
$cshow :: Encoding -> String
showsPrec :: Int -> Encoding -> ShowS
$cshowsPrec :: Int -> Encoding -> ShowS
Show, (forall x. Encoding -> Rep Encoding x)
-> (forall x. Rep Encoding x -> Encoding) -> Generic Encoding
forall x. Rep Encoding x -> Encoding
forall x. Encoding -> Rep Encoding x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Encoding x -> Encoding
$cfrom :: forall x. Encoding -> Rep Encoding x
Generic)

-- | Multiple alternative representations of the same data. For example, you
-- could provide a plain-text and HTML version of a message.
type Alternatives = [Part]

-- | A single part of a multipart message.
data Part = Part
    { Part -> Text
partType :: Text -- ^ content type
    , Part -> Encoding
partEncoding :: Encoding
    -- | The filename for this part, if it is to be sent with an attachemnt
    -- disposition.
    , Part -> Disposition
partDisposition :: Disposition
    , Part -> Headers
partHeaders :: Headers
    , Part -> PartContent
partContent :: PartContent
    }
  deriving (Part -> Part -> Bool
(Part -> Part -> Bool) -> (Part -> Part -> Bool) -> Eq Part
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Part -> Part -> Bool
$c/= :: Part -> Part -> Bool
== :: Part -> Part -> Bool
$c== :: Part -> Part -> Bool
Eq, Int -> Part -> ShowS
Alternatives -> ShowS
Part -> String
(Int -> Part -> ShowS)
-> (Part -> String) -> (Alternatives -> ShowS) -> Show Part
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: Alternatives -> ShowS
$cshowList :: Alternatives -> ShowS
show :: Part -> String
$cshow :: Part -> String
showsPrec :: Int -> Part -> ShowS
$cshowsPrec :: Int -> Part -> ShowS
Show, (forall x. Part -> Rep Part x)
-> (forall x. Rep Part x -> Part) -> Generic Part
forall x. Rep Part x -> Part
forall x. Part -> Rep Part x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Part x -> Part
$cfrom :: forall x. Part -> Rep Part x
Generic)

-- | NestedParts are for multipart-related: One HTML part and some inline images
data PartContent = PartContent L.ByteString | NestedParts [Part]
  deriving (PartContent -> PartContent -> Bool
(PartContent -> PartContent -> Bool)
-> (PartContent -> PartContent -> Bool) -> Eq PartContent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PartContent -> PartContent -> Bool
$c/= :: PartContent -> PartContent -> Bool
== :: PartContent -> PartContent -> Bool
$c== :: PartContent -> PartContent -> Bool
Eq, Int -> PartContent -> ShowS
[PartContent] -> ShowS
PartContent -> String
(Int -> PartContent -> ShowS)
-> (PartContent -> String)
-> ([PartContent] -> ShowS)
-> Show PartContent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PartContent] -> ShowS
$cshowList :: [PartContent] -> ShowS
show :: PartContent -> String
$cshow :: PartContent -> String
showsPrec :: Int -> PartContent -> ShowS
$cshowsPrec :: Int -> PartContent -> ShowS
Show, (forall x. PartContent -> Rep PartContent x)
-> (forall x. Rep PartContent x -> PartContent)
-> Generic PartContent
forall x. Rep PartContent x -> PartContent
forall x. PartContent -> Rep PartContent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PartContent x -> PartContent
$cfrom :: forall x. PartContent -> Rep PartContent x
Generic)

data Disposition = AttachmentDisposition Text
                 | InlineDisposition Text
                 | DefaultDisposition
                 deriving (Int -> Disposition -> ShowS
[Disposition] -> ShowS
Disposition -> String
(Int -> Disposition -> ShowS)
-> (Disposition -> String)
-> ([Disposition] -> ShowS)
-> Show Disposition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Disposition] -> ShowS
$cshowList :: [Disposition] -> ShowS
show :: Disposition -> String
$cshow :: Disposition -> String
showsPrec :: Int -> Disposition -> ShowS
$cshowsPrec :: Int -> Disposition -> ShowS
Show, Disposition -> Disposition -> Bool
(Disposition -> Disposition -> Bool)
-> (Disposition -> Disposition -> Bool) -> Eq Disposition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Disposition -> Disposition -> Bool
$c/= :: Disposition -> Disposition -> Bool
== :: Disposition -> Disposition -> Bool
$c== :: Disposition -> Disposition -> Bool
Eq, (forall x. Disposition -> Rep Disposition x)
-> (forall x. Rep Disposition x -> Disposition)
-> Generic Disposition
forall x. Rep Disposition x -> Disposition
forall x. Disposition -> Rep Disposition x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Disposition x -> Disposition
$cfrom :: forall x. Disposition -> Rep Disposition x
Generic)

type Headers = [(S.ByteString, Text)]

data Pair = Pair (Headers, Builder)
          | CompoundPair (Headers, [Pair])

partToPair :: Part -> Pair
partToPair :: Part -> Pair
partToPair (Part Text
contentType Encoding
encoding Disposition
disposition Headers
headers (PartContent ByteString
content)) =
    (Headers, Builder) -> Pair
Pair (Headers
headers', Builder
builder)
  where
    headers' :: Headers
headers' =
        ((:) (ByteString
"Content-Type", Text
contentType))
      (Headers -> Headers) -> Headers -> Headers
forall a b. (a -> b) -> a -> b
$ (case Encoding
encoding of
            Encoding
None -> Headers -> Headers
forall a. a -> a
id
            Encoding
Base64 -> (:) (ByteString
"Content-Transfer-Encoding", Text
"base64")
            Encoding
QuotedPrintableText ->
                (:) (ByteString
"Content-Transfer-Encoding", Text
"quoted-printable")
            Encoding
QuotedPrintableBinary ->
                (:) (ByteString
"Content-Transfer-Encoding", Text
"quoted-printable"))
      (Headers -> Headers) -> Headers -> Headers
forall a b. (a -> b) -> a -> b
$ (case Disposition
disposition of
            AttachmentDisposition Text
fn ->
                (:) (ByteString
"Content-Disposition", Text
"attachment; filename=" Text -> Text -> Text
`T.append` Text
fn)
            InlineDisposition Text
cid ->
                (:) (ByteString
"Content-Disposition", Text
"inline; filename=" Text -> Text -> Text
`T.append` Text
cid) (Headers -> Headers) -> (Headers -> Headers) -> Headers -> Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) (ByteString
"Content-ID", Text
"<" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">") (Headers -> Headers) -> (Headers -> Headers) -> Headers -> Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) (ByteString
"Content-Location", Text
cid)
            Disposition
DefaultDisposition -> Headers -> Headers
forall a. a -> a
id
        )
      (Headers -> Headers) -> Headers -> Headers
forall a b. (a -> b) -> a -> b
$ Headers
headers
    builder :: Builder
builder =
        case Encoding
encoding of
            Encoding
None -> (ByteString -> Write) -> [ByteString] -> Builder
forall a. (a -> Write) -> [a] -> Builder
fromWriteList ByteString -> Write
writeByteString ([ByteString] -> Builder) -> [ByteString] -> Builder
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks ByteString
content
            Encoding
Base64 -> ByteString -> Builder
base64 ByteString
content
            Encoding
QuotedPrintableText -> Bool -> ByteString -> Builder
quotedPrintable Bool
True ByteString
content
            Encoding
QuotedPrintableBinary -> Bool -> ByteString -> Builder
quotedPrintable Bool
False ByteString
content
partToPair (Part Text
contentType Encoding
encoding Disposition
disposition Headers
headers (NestedParts Alternatives
parts)) =
    (Headers, [Pair]) -> Pair
CompoundPair (Headers
headers', [Pair]
pairs)
  where
    headers' :: Headers
headers' = (ByteString
"Content-Type", Text
contentType)(ByteString, Text) -> Headers -> Headers
forall a. a -> [a] -> [a]
:Headers
headers
    pairs :: [Pair]
pairs = (Part -> Pair) -> Alternatives -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map Part -> Pair
partToPair Alternatives
parts


-- This function merges sibling pairs into a multipart pair
showPairs :: RandomGen g
          => Text -- ^ multipart type, eg mixed, alternative
          -> [Pair]
          -> g
          -> (Pair, g)
showPairs :: Text -> [Pair] -> g -> (Pair, g)
showPairs Text
_ [] g
_ = String -> (Pair, g)
forall a. HasCallStack => String -> a
error String
"renderParts called with null parts"
showPairs Text
_ [Pair
pair] g
gen = (Pair
pair, g
gen)
showPairs Text
mtype [Pair]
parts g
gen =
    ((Headers, Builder) -> Pair
Pair (Headers
headers, Builder
builder), g
gen')
  where
    (Boundary Text
b, g
gen') = g -> (Boundary, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random g
gen
    headers :: Headers
headers =
        [ (ByteString
"Content-Type", [Text] -> Text
T.concat
            [ Text
"multipart/"
            , Text
mtype
            , Text
"; boundary=\""
            , Text
b
            , Text
"\""
            ])
        ]
    builder :: Builder
builder = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
        [ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (ByteString -> Builder
fromByteString ByteString
"\n")
                  ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$ (Pair -> Builder) -> [Pair] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Boundary -> Pair -> Builder
showBoundPart (Boundary -> Pair -> Builder) -> Boundary -> Pair -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Boundary
Boundary Text
b) [Pair]
parts
        , Boundary -> Builder
showBoundEnd (Boundary -> Builder) -> Boundary -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Boundary
Boundary Text
b
        ]

-- This function flattens any compound pairs into a multipart
-- related, but leaves other pairs in tact
-- NOTE that this is not recursive, and assumes only one level of nesting.
flattenCompoundPair :: RandomGen g => Pair -> g -> (Pair, g)
flattenCompoundPair :: Pair -> g -> (Pair, g)
flattenCompoundPair pair :: Pair
pair@(Pair (Headers, Builder)
_) g
gen = (Pair
pair, g
gen)
flattenCompoundPair (CompoundPair (Headers
hs, [Pair]
pairs)) g
gen =
       ((Headers, Builder) -> Pair
Pair (Headers
headers, Builder
builder), g
gen')
  where
    (Boundary Text
b, g
gen') = g -> (Boundary, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random g
gen
    headers :: Headers
headers =
        [ (ByteString
"Content-Type", [Text] -> Text
T.concat
            [ Text
"multipart/related" , Text
"; boundary=\"" , Text
b , Text
"\"" ])
        ]
    builder :: Builder
builder = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
        [ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (ByteString -> Builder
fromByteString ByteString
"\n")
                  ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$ (Pair -> Builder) -> [Pair] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Boundary -> Pair -> Builder
showBoundPart (Boundary -> Pair -> Builder) -> Boundary -> Pair -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Boundary
Boundary Text
b) [Pair]
pairs
        , Boundary -> Builder
showBoundEnd (Boundary -> Builder) -> Boundary -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Boundary
Boundary Text
b
        ]


-- | Render a 'Mail' with a given 'RandomGen' for producing boundaries.
renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g)
renderMail :: g -> Mail -> (ByteString, g)
renderMail g
g0 (Mail Address
from [Address]
to [Address]
cc [Address]
bcc Headers
headers [Alternatives]
parts) =
    (Builder -> ByteString
toLazyByteString Builder
builder, g
g'')
  where
    addressHeaders :: [Builder]
addressHeaders = ((ByteString, [Address]) -> Builder)
-> [(ByteString, [Address])] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, [Address]) -> Builder
showAddressHeader [(ByteString
"From", [Address
from]), (ByteString
"To", [Address]
to), (ByteString
"Cc", [Address]
cc), (ByteString
"Bcc", [Address]
bcc)]
    -- parts is [Alternative], or [[Part]]
    -- reverse parts so attachments come at the end
    pairs :: [[Pair]]
    pairs :: [[Pair]]
pairs = (Alternatives -> [Pair]) -> [Alternatives] -> [[Pair]]
forall a b. (a -> b) -> [a] -> [b]
map ((Part -> Pair) -> Alternatives -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map Part -> Pair
partToPair) ([Alternatives] -> [Alternatives]
forall a. [a] -> [a]
reverse [Alternatives]
parts)

    ([[Pair]]
pairs1, g
g1) = g -> [[g -> (Pair, g)]] -> ([[Pair]], g)
forall g x. g -> [[g -> (x, g)]] -> ([[x]], g)
helper2 g
g0 ([[g -> (Pair, g)]] -> ([[Pair]], g))
-> [[g -> (Pair, g)]] -> ([[Pair]], g)
forall a b. (a -> b) -> a -> b
$ ([Pair] -> [g -> (Pair, g)]) -> [[Pair]] -> [[g -> (Pair, g)]]
forall a b. (a -> b) -> [a] -> [b]
map ((Pair -> g -> (Pair, g)) -> [Pair] -> [g -> (Pair, g)]
forall a b. (a -> b) -> [a] -> [b]
map Pair -> g -> (Pair, g)
forall g. RandomGen g => Pair -> g -> (Pair, g)
flattenCompoundPair) [[Pair]]
pairs
    ([Pair]
pairs', g
g') = g -> [g -> (Pair, g)] -> ([Pair], g)
forall g x. g -> [g -> (x, g)] -> ([x], g)
helper g
g1 ([g -> (Pair, g)] -> ([Pair], g))
-> [g -> (Pair, g)] -> ([Pair], g)
forall a b. (a -> b) -> a -> b
$ ([Pair] -> g -> (Pair, g)) -> [[Pair]] -> [g -> (Pair, g)]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Pair] -> g -> (Pair, g)
forall g. RandomGen g => Text -> [Pair] -> g -> (Pair, g)
showPairs Text
"alternative") [[Pair]]
pairs1

    helper :: g -> [g -> (x, g)] -> ([x], g)
    helper :: g -> [g -> (x, g)] -> ([x], g)
helper g
g [] = ([], g
g)
    helper g
g (g -> (x, g)
x:[g -> (x, g)]
xs) =
        let (x
b, g
g_) = g -> (x, g)
x g
g
            ([x]
bs, g
g__) = g -> [g -> (x, g)] -> ([x], g)
forall g x. g -> [g -> (x, g)] -> ([x], g)
helper g
g_ [g -> (x, g)]
xs
         in (x
b x -> [x] -> [x]
forall a. a -> [a] -> [a]
: [x]
bs, g
g__)

    -- new 2nd order helper
    helper2 :: g -> [[g -> (x, g)]] -> ([[x]], g)
    helper2 :: g -> [[g -> (x, g)]] -> ([[x]], g)
helper2 g
g [] = ([], g
g)
    helper2 g
g ([g -> (x, g)]
x:[[g -> (x, g)]]
xs) =
        let ([x]
b, g
g_) = g -> [g -> (x, g)] -> ([x], g)
forall g x. g -> [g -> (x, g)] -> ([x], g)
helper g
g [g -> (x, g)]
x  -- original helper
            ([[x]]
bs, g
g__) = g -> [[g -> (x, g)]] -> ([[x]], g)
forall g x. g -> [[g -> (x, g)]] -> ([[x]], g)
helper2 g
g_ [[g -> (x, g)]]
xs
         in ([x]
b [x] -> [[x]] -> [[x]]
forall a. a -> [a] -> [a]
: [[x]]
bs, g
g__)

    (Pair (Headers
finalHeaders, Builder
finalBuilder), g
g'') = Text -> [Pair] -> g -> (Pair, g)
forall g. RandomGen g => Text -> [Pair] -> g -> (Pair, g)
showPairs Text
"mixed" [Pair]
pairs' g
g'
    builder :: Builder
builder = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
        [ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
addressHeaders
        , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ ((ByteString, Text) -> Builder) -> Headers -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Text) -> Builder
showHeader Headers
headers
        , (ByteString, Text) -> Builder
showHeader (ByteString
"MIME-Version", Text
"1.0")
        , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ ((ByteString, Text) -> Builder) -> Headers -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Text) -> Builder
showHeader Headers
finalHeaders
        , ByteString -> Builder
fromByteString ByteString
"\n"
        , Builder
finalBuilder
        ]

-- | Format an E-Mail address according to the name-addr form (see: RFC5322
-- § 3.4 "Address specification", i.e: [display-name] '<'addr-spec'>')
-- This can be handy for adding custom headers that require such format.
--
-- @since 0.4.11
renderAddress :: Address -> Text
renderAddress :: Address -> Text
renderAddress Address
address =
    ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Address -> Builder
showAddress Address
address

-- Only accept characters between 33 and 126, excluding colons. [RFC2822](https://tools.ietf.org/html/rfc2822#section-2.2)
sanitizeFieldName :: S.ByteString -> S.ByteString
sanitizeFieldName :: ByteString -> ByteString
sanitizeFieldName = (Word8 -> Bool) -> ByteString -> ByteString
S.filter (\Word8
w -> Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
33 Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
126 Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
58)

showHeader :: (S.ByteString, Text) -> Builder
showHeader :: (ByteString, Text) -> Builder
showHeader (ByteString
k, Text
v) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ ByteString -> Builder
fromByteString (ByteString -> ByteString
sanitizeFieldName ByteString
k)
    , ByteString -> Builder
fromByteString ByteString
": "
    , Text -> Builder
encodeIfNeeded (Text -> Text
sanitizeHeader Text
v)
    , ByteString -> Builder
fromByteString ByteString
"\n"
    ]

showAddressHeader :: (S.ByteString, [Address]) -> Builder
showAddressHeader :: (ByteString, [Address]) -> Builder
showAddressHeader (ByteString
k, [Address]
as) =
  if [Address] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Address]
as
  then Builder
forall a. Monoid a => a
mempty
  else [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ ByteString -> Builder
fromByteString ByteString
k
    , ByteString -> Builder
fromByteString ByteString
": "
    , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (ByteString -> Builder
fromByteString ByteString
", ") ([Builder] -> [Builder])
-> ([Address] -> [Builder]) -> [Address] -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Address -> Builder) -> [Address] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Address -> Builder
showAddress ([Address] -> [Builder]) -> [Address] -> [Builder]
forall a b. (a -> b) -> a -> b
$ [Address]
as)
    , ByteString -> Builder
fromByteString ByteString
"\n"
    ]

-- |
--
-- Since 0.4.3
showAddress :: Address -> Builder
showAddress :: Address -> Builder
showAddress Address
a = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ Builder -> (Text -> Builder) -> Maybe Text -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
forall a. Monoid a => a
mempty ((Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
fromByteString ByteString
" ") (Builder -> Builder) -> (Text -> Builder) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
encodedWord) (Address -> Maybe Text
addressName Address
a)
    , ByteString -> Builder
fromByteString ByteString
"<"
    , Text -> Builder
fromText (Text -> Text
sanitizeHeader (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Address -> Text
addressEmail Address
a)
    , ByteString -> Builder
fromByteString ByteString
">"
    ]

-- Filter out control characters to prevent CRLF injection.
sanitizeHeader :: Text -> Text
sanitizeHeader :: Text -> Text
sanitizeHeader = (Char -> Bool) -> Text -> Text
T.filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isControl)

showBoundPart :: Boundary -> Pair -> Builder
showBoundPart :: Boundary -> Pair -> Builder
showBoundPart (Boundary Text
b) (Pair (Headers
headers, Builder
content)) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ ByteString -> Builder
fromByteString ByteString
"--"
    , Text -> Builder
fromText Text
b
    , ByteString -> Builder
fromByteString ByteString
"\n"
    , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ ((ByteString, Text) -> Builder) -> Headers -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Text) -> Builder
showHeader Headers
headers
    , ByteString -> Builder
fromByteString ByteString
"\n"
    , Builder
content
    ]

showBoundEnd :: Boundary -> Builder
showBoundEnd :: Boundary -> Builder
showBoundEnd (Boundary Text
b) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ ByteString -> Builder
fromByteString ByteString
"\n--"
    , Text -> Builder
fromText Text
b
    , ByteString -> Builder
fromByteString ByteString
"--"
    ]

-- | Like 'renderMail', but generates a random boundary.
renderMail' :: Mail -> IO L.ByteString
renderMail' :: Mail -> IO ByteString
renderMail' Mail
m = do
    StdGen
g <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
getStdGen
    let (ByteString
lbs, StdGen
g') = StdGen -> Mail -> (ByteString, StdGen)
forall g. RandomGen g => g -> Mail -> (ByteString, g)
renderMail StdGen
g Mail
m
    StdGen -> IO ()
forall (m :: * -> *). MonadIO m => StdGen -> m ()
setStdGen StdGen
g'
    ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
lbs

-- | Send a fully-formed email message via the default sendmail
-- executable with default options.
sendmail :: L.ByteString -> IO ()
sendmail :: ByteString -> IO ()
sendmail = String -> [String] -> ByteString -> IO ()
sendmailCustom String
sendmailPath [String
"-t"]

sendmailPath :: String
#ifdef MIME_MAIL_SENDMAIL_PATH
sendmailPath = MIME_MAIL_SENDMAIL_PATH
#else
sendmailPath :: String
sendmailPath = String
"/usr/sbin/sendmail"
#endif

-- | Render an email message and send via the default sendmail
-- executable with default options.
renderSendMail :: Mail -> IO ()
renderSendMail :: Mail -> IO ()
renderSendMail = ByteString -> IO ()
sendmail (ByteString -> IO ()) -> (Mail -> IO ByteString) -> Mail -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Mail -> IO ByteString
renderMail'

-- | Send a fully-formed email message via the specified sendmail
-- executable with specified options.
sendmailCustom :: FilePath        -- ^ sendmail executable path
                  -> [String]     -- ^ sendmail command-line options
                  -> L.ByteString -- ^ mail message as lazy bytestring
                  -> IO ()
sendmailCustom :: String -> [String] -> ByteString -> IO ()
sendmailCustom String
sm [String]
opts ByteString
lbs = IO (ByteString, ByteString) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ByteString, ByteString) -> IO ())
-> IO (ByteString, ByteString) -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool
-> String -> [String] -> ByteString -> IO (ByteString, ByteString)
sendmailCustomAux Bool
False String
sm [String]
opts ByteString
lbs

-- | Like 'sendmailCustom', but also returns sendmail's output to stderr and
-- stdout as strict ByteStrings.
--
-- Since 0.4.9
sendmailCustomCaptureOutput :: FilePath
                               -> [String]
                               -> L.ByteString
                               -> IO (S.ByteString, S.ByteString)
sendmailCustomCaptureOutput :: String -> [String] -> ByteString -> IO (ByteString, ByteString)
sendmailCustomCaptureOutput String
sm [String]
opts ByteString
lbs = Bool
-> String -> [String] -> ByteString -> IO (ByteString, ByteString)
sendmailCustomAux Bool
True String
sm [String]
opts ByteString
lbs

sendmailCustomAux :: Bool
                     -> FilePath
                     -> [String]
                     -> L.ByteString
                     -> IO (S.ByteString, S.ByteString)
sendmailCustomAux :: Bool
-> String -> [String] -> ByteString -> IO (ByteString, ByteString)
sendmailCustomAux Bool
captureOut String
sm [String]
opts ByteString
lbs = do
    let baseOpts :: CreateProcess
baseOpts = (String -> [String] -> CreateProcess
proc String
sm [String]
opts) { std_in :: StdStream
std_in = StdStream
CreatePipe }
        pOpts :: CreateProcess
pOpts = if Bool
captureOut
                    then CreateProcess
baseOpts { std_out :: StdStream
std_out = StdStream
CreatePipe
                                  , std_err :: StdStream
std_err = StdStream
CreatePipe
                                  }
                    else CreateProcess
baseOpts
    (Just Handle
hin, Maybe Handle
mHOut, Maybe Handle
mHErr, ProcessHandle
phandle) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
pOpts
    Handle -> ByteString -> IO ()
L.hPut Handle
hin ByteString
lbs
    Handle -> IO ()
hClose Handle
hin
    MVar ByteString
errMVar <- IO (MVar ByteString)
forall a. IO (MVar a)
newEmptyMVar
    MVar ByteString
outMVar <- IO (MVar ByteString)
forall a. IO (MVar a)
newEmptyMVar
    case (Maybe Handle
mHOut, Maybe Handle
mHErr) of
        (Maybe Handle
Nothing, Maybe Handle
Nothing) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (Just Handle
hOut, Just Handle
hErr) -> do
            IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ByteString
S.hGetContents Handle
hOut IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar ByteString -> ByteString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ByteString
outMVar
            IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ByteString
S.hGetContents Handle
hErr IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar ByteString -> ByteString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ByteString
errMVar
        (Maybe Handle, Maybe Handle)
_ -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"error in sendmailCustomAux: missing a handle"
    ExitCode
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
phandle
    case ExitCode
exitCode of
        ExitCode
ExitSuccess -> if Bool
captureOut
            then do
                ByteString
errOutput <- MVar ByteString -> IO ByteString
forall a. MVar a -> IO a
takeMVar MVar ByteString
errMVar
                ByteString
outOutput <- MVar ByteString -> IO ByteString
forall a. MVar a -> IO a
takeMVar MVar ByteString
outMVar
                (ByteString, ByteString) -> IO (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
outOutput, ByteString
errOutput)
            else (ByteString, ByteString) -> IO (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
S.empty, ByteString
S.empty)
        ExitCode
_ -> ErrorCall -> IO (ByteString, ByteString)
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO (ByteString, ByteString))
-> ErrorCall -> IO (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall (String
"sendmail exited with error code " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
exitCode)

-- | Render an email message and send via the specified sendmail
-- executable with specified options.
renderSendMailCustom :: FilePath    -- ^ sendmail executable path
                        -> [String] -- ^ sendmail command-line options
                        -> Mail     -- ^ mail to render and send
                        -> IO ()
renderSendMailCustom :: String -> [String] -> Mail -> IO ()
renderSendMailCustom String
sm [String]
opts = String -> [String] -> ByteString -> IO ()
sendmailCustom String
sm [String]
opts (ByteString -> IO ()) -> (Mail -> IO ByteString) -> Mail -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Mail -> IO ByteString
renderMail'

-- FIXME usage of FilePath below can lead to issues with filename encoding

-- | A simple interface for generating an email with HTML and plain-text
-- alternatives and some file attachments.
--
-- Note that we use lazy IO for reading in the attachment contents.
simpleMail :: Address -- ^ to
           -> Address -- ^ from
           -> Text -- ^ subject
           -> LT.Text -- ^ plain body
           -> LT.Text -- ^ HTML body
           -> [(Text, FilePath)] -- ^ content type and path of attachments
           -> IO Mail
simpleMail :: Address
-> Address -> Text -> Text -> Text -> [(Text, String)] -> IO Mail
simpleMail Address
to Address
from Text
subject Text
plainBody Text
htmlBody [(Text, String)]
attachments =
      [(Text, String)] -> Mail -> IO Mail
addAttachments [(Text, String)]
attachments
    (Mail -> IO Mail) -> (Mail -> Mail) -> Mail -> IO Mail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alternatives -> Mail -> Mail
addPart [Text -> Part
plainPart Text
plainBody, Text -> Part
htmlPart Text
htmlBody]
    (Mail -> IO Mail) -> Mail -> IO Mail
forall a b. (a -> b) -> a -> b
$ Address -> Address -> Text -> Mail
mailFromToSubject Address
from Address
to Text
subject

-- | A simple interface for generating an email with only plain-text body.
simpleMail' :: Address -- ^ to
            -> Address -- ^ from
            -> Text -- ^ subject
            -> LT.Text -- ^ body
            -> Mail
simpleMail' :: Address -> Address -> Text -> Text -> Mail
simpleMail' Address
to Address
from Text
subject Text
body = Alternatives -> Mail -> Mail
addPart [Text -> Part
plainPart Text
body]
                                 (Mail -> Mail) -> Mail -> Mail
forall a b. (a -> b) -> a -> b
$ Address -> Address -> Text -> Mail
mailFromToSubject Address
from Address
to Text
subject

-- | A simple interface for generating an email with HTML and plain-text
-- alternatives and some 'ByteString' attachments.
--
-- Since 0.4.7
simpleMailInMemory :: Address -- ^ to
           -> Address -- ^ from
           -> Text -- ^ subject
           -> LT.Text -- ^ plain body
           -> LT.Text -- ^ HTML body
           -> [(Text, Text, L.ByteString)] -- ^ content type, file name and contents of attachments
           -> Mail
simpleMailInMemory :: Address
-> Address
-> Text
-> Text
-> Text
-> [(Text, Text, ByteString)]
-> Mail
simpleMailInMemory Address
to Address
from Text
subject Text
plainBody Text
htmlBody [(Text, Text, ByteString)]
attachments =
      [(Text, Text, ByteString)] -> Mail -> Mail
addAttachmentsBS [(Text, Text, ByteString)]
attachments
    (Mail -> Mail) -> (Mail -> Mail) -> Mail -> Mail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alternatives -> Mail -> Mail
addPart [Text -> Part
plainPart Text
plainBody, Text -> Part
htmlPart Text
htmlBody]
    (Mail -> Mail) -> Mail -> Mail
forall a b. (a -> b) -> a -> b
$ Address -> Address -> Text -> Mail
mailFromToSubject Address
from Address
to Text
subject


data InlineImage = InlineImage {
      InlineImage -> Text
imageContentType :: Text
    , InlineImage -> ImageContent
imageContent :: ImageContent
    , InlineImage -> Text
imageCID :: Text
    } deriving Int -> InlineImage -> ShowS
[InlineImage] -> ShowS
InlineImage -> String
(Int -> InlineImage -> ShowS)
-> (InlineImage -> String)
-> ([InlineImage] -> ShowS)
-> Show InlineImage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InlineImage] -> ShowS
$cshowList :: [InlineImage] -> ShowS
show :: InlineImage -> String
$cshow :: InlineImage -> String
showsPrec :: Int -> InlineImage -> ShowS
$cshowsPrec :: Int -> InlineImage -> ShowS
Show

data ImageContent = ImageFilePath FilePath | ImageByteString L.ByteString
  deriving Int -> ImageContent -> ShowS
[ImageContent] -> ShowS
ImageContent -> String
(Int -> ImageContent -> ShowS)
-> (ImageContent -> String)
-> ([ImageContent] -> ShowS)
-> Show ImageContent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImageContent] -> ShowS
$cshowList :: [ImageContent] -> ShowS
show :: ImageContent -> String
$cshow :: ImageContent -> String
showsPrec :: Int -> ImageContent -> ShowS
$cshowsPrec :: Int -> ImageContent -> ShowS
Show

-- | An interface for generating an email with HTML and plain-text
-- alternatives, some file attachments, and inline images.
-- Note that we use lazy IO for reading in the attachment and inlined images.
-- Inline images can be referred to from the HTML content using
-- the @src="cid:{{CONTENT-ID}}"@ syntax, where CONTENT-ID is
-- the filename of the image.
--
-- Since 0.5.0
simpleMailWithImages :: [Address] -- ^ to (multiple)
           -> Address -- ^ from
           -> Text -- ^ subject
           -> LT.Text -- ^ plain body
           -> LT.Text -- ^ HTML body
           -> [InlineImage]
           -> [(Text, FilePath)] -- ^ content type and path of attachments
           -> IO Mail
simpleMailWithImages :: [Address]
-> Address
-> Text
-> Text
-> Text
-> [InlineImage]
-> [(Text, String)]
-> IO Mail
simpleMailWithImages [Address]
to Address
from Text
subject Text
plainBody Text
htmlBody [InlineImage]
images [(Text, String)]
attachments = do
    Alternatives
inlineImageParts <- [InlineImage] -> IO Alternatives
mkImageParts [InlineImage]
images
    [(Text, String)] -> Mail -> IO Mail
addAttachments [(Text, String)]
attachments
      (Mail -> IO Mail) -> (Mail -> Mail) -> Mail -> IO Mail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alternatives -> Mail -> Mail
addPart [ Text -> Part
plainPart Text
plainBody
                , Alternatives -> Part
relatedPart ((Text -> Part
htmlPart Text
htmlBody)Part -> Alternatives -> Alternatives
forall a. a -> [a] -> [a]
:Alternatives
inlineImageParts) ]
      (Mail -> IO Mail) -> Mail -> IO Mail
forall a b. (a -> b) -> a -> b
$ (Address -> Mail
emptyMail Address
from) { mailTo :: [Address]
mailTo = [Address]
to, mailHeaders :: Headers
mailHeaders = [(ByteString
"Subject", Text
subject)] }

mailFromToSubject :: Address -- ^ from
                  -> Address -- ^ to
                  -> Text -- ^ subject
                  -> Mail
mailFromToSubject :: Address -> Address -> Text -> Mail
mailFromToSubject Address
from Address
to Text
subject =
    (Address -> Mail
emptyMail Address
from) { mailTo :: [Address]
mailTo = [Address
to]
                     , mailHeaders :: Headers
mailHeaders = [(ByteString
"Subject", Text
subject)]
                     }

-- | Add an 'Alternative' to the 'Mail's parts.
--
-- To e.g. add a plain text body use
-- > addPart [plainPart body] (emptyMail from)
addPart :: Alternatives -> Mail -> Mail
addPart :: Alternatives -> Mail -> Mail
addPart Alternatives
alt Mail
mail = Mail
mail { mailParts :: [Alternatives]
mailParts = Alternatives
alt Alternatives -> [Alternatives] -> [Alternatives]
forall a. a -> [a] -> [a]
: Mail -> [Alternatives]
mailParts Mail
mail }

-- | Add a 'Related' Part
relatedPart :: [Part] -> Part
relatedPart :: Alternatives -> Part
relatedPart Alternatives
parts =
   Text -> Encoding -> Disposition -> Headers -> PartContent -> Part
Part Text
"multipart/related" Encoding
None Disposition
DefaultDisposition [] (Alternatives -> PartContent
NestedParts Alternatives
parts)

-- | Construct a UTF-8-encoded plain-text 'Part'.
plainPart :: LT.Text -> Part
plainPart :: Text -> Part
plainPart Text
body = Text -> Encoding -> Disposition -> Headers -> PartContent -> Part
Part Text
cType Encoding
QuotedPrintableText Disposition
DefaultDisposition []
    (PartContent -> Part) -> PartContent -> Part
forall a b. (a -> b) -> a -> b
$ ByteString -> PartContent
PartContent (Text -> ByteString
LT.encodeUtf8 Text
body)
  where cType :: Text
cType = Text
"text/plain; charset=utf-8"

-- | Construct a UTF-8-encoded html 'Part'.
htmlPart :: LT.Text -> Part
htmlPart :: Text -> Part
htmlPart Text
body = Text -> Encoding -> Disposition -> Headers -> PartContent -> Part
Part Text
cType Encoding
QuotedPrintableText Disposition
DefaultDisposition []
    (PartContent -> Part) -> PartContent -> Part
forall a b. (a -> b) -> a -> b
$ ByteString -> PartContent
PartContent (Text -> ByteString
LT.encodeUtf8 Text
body)
  where cType :: Text
cType = Text
"text/html; charset=utf-8"

-- | Construct a BASE64-encoded file attachment 'Part'
--
-- Since 0.5.0
filePart :: Text -> FilePath -> IO Part
filePart :: Text -> String -> IO Part
filePart Text
ct String
fn = do
    ByteString
content <- String -> IO ByteString
L.readFile String
fn
    Part -> IO Part
forall (m :: * -> *) a. Monad m => a -> m a
return (Part -> IO Part) -> Part -> IO Part
forall a b. (a -> b) -> a -> b
$ Text -> Text -> ByteString -> Part
filePartBS Text
ct (String -> Text
T.pack (ShowS
takeFileName String
fn)) ByteString
content

-- | Construct a BASE64-encoded file attachment 'Part'
--
-- Since 0.5.0
filePartBS :: Text -> Text -> L.ByteString -> Part
filePartBS :: Text -> Text -> ByteString -> Part
filePartBS Text
ct Text
filename ByteString
content = Text -> Encoding -> Disposition -> Headers -> PartContent -> Part
Part Text
ct Encoding
Base64 (Text -> Disposition
AttachmentDisposition Text
filename) [] (ByteString -> PartContent
PartContent ByteString
content)

-- | Add an attachment from a file and construct a 'Part'.
addAttachment :: Text -> FilePath -> Mail -> IO Mail
addAttachment :: Text -> String -> Mail -> IO Mail
addAttachment Text
ct String
fn Mail
mail = do
    Part
part <- Text -> String -> IO Part
filePart Text
ct String
fn
    Mail -> IO Mail
forall (m :: * -> *) a. Monad m => a -> m a
return (Mail -> IO Mail) -> Mail -> IO Mail
forall a b. (a -> b) -> a -> b
$ Alternatives -> Mail -> Mail
addPart [Part
part] Mail
mail

addAttachments :: [(Text, FilePath)] -> Mail -> IO Mail
addAttachments :: [(Text, String)] -> Mail -> IO Mail
addAttachments [(Text, String)]
xs Mail
mail = (Mail -> (Text, String) -> IO Mail)
-> Mail -> [(Text, String)] -> IO Mail
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Mail -> (Text, String) -> IO Mail
fun Mail
mail [(Text, String)]
xs
  where fun :: Mail -> (Text, String) -> IO Mail
fun Mail
m (Text
c, String
f) = Text -> String -> Mail -> IO Mail
addAttachment Text
c String
f Mail
m

-- | Add an inline image from a file and construct a 'Part'.
--
-- Since 0.5.0
addImage :: InlineImage -> IO Part
addImage :: InlineImage -> IO Part
addImage InlineImage{Text
ImageContent
imageCID :: Text
imageContent :: ImageContent
imageContentType :: Text
imageCID :: InlineImage -> Text
imageContent :: InlineImage -> ImageContent
imageContentType :: InlineImage -> Text
..} = do
    ByteString
content <- case ImageContent
imageContent of
                ImageFilePath String
fn -> String -> IO ByteString
L.readFile String
fn
                ImageByteString ByteString
bs -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
    Part -> IO Part
forall (m :: * -> *) a. Monad m => a -> m a
return
      (Part -> IO Part) -> Part -> IO Part
forall a b. (a -> b) -> a -> b
$ Text -> Encoding -> Disposition -> Headers -> PartContent -> Part
Part Text
imageContentType Encoding
Base64 (Text -> Disposition
InlineDisposition Text
imageCID) [] (ByteString -> PartContent
PartContent ByteString
content)

mkImageParts :: [InlineImage] -> IO [Part]
mkImageParts :: [InlineImage] -> IO Alternatives
mkImageParts [InlineImage]
xs =
    (InlineImage -> IO Part) -> [InlineImage] -> IO Alternatives
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM InlineImage -> IO Part
addImage [InlineImage]
xs

-- | Add an attachment from a 'ByteString' and construct a 'Part'.
--
-- Since 0.4.7
addAttachmentBS :: Text -- ^ content type
                -> Text -- ^ file name
                -> L.ByteString -- ^ content
                -> Mail -> Mail
addAttachmentBS :: Text -> Text -> ByteString -> Mail -> Mail
addAttachmentBS Text
ct Text
fn ByteString
content Mail
mail = Alternatives -> Mail -> Mail
addPart [Text -> Text -> ByteString -> Part
filePartBS Text
ct Text
fn ByteString
content] Mail
mail

-- |
-- Since 0.4.7
addAttachmentsBS :: [(Text, Text, L.ByteString)] -> Mail -> Mail
addAttachmentsBS :: [(Text, Text, ByteString)] -> Mail -> Mail
addAttachmentsBS [(Text, Text, ByteString)]
xs Mail
mail = (Mail -> (Text, Text, ByteString) -> Mail)
-> Mail -> [(Text, Text, ByteString)] -> Mail
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Mail -> (Text, Text, ByteString) -> Mail
fun Mail
mail [(Text, Text, ByteString)]
xs
  where fun :: Mail -> (Text, Text, ByteString) -> Mail
fun Mail
m (Text
ct, Text
fn, ByteString
content) = Text -> Text -> ByteString -> Mail -> Mail
addAttachmentBS Text
ct Text
fn ByteString
content Mail
m


data QP = QPPlain S.ByteString
        | QPNewline
        | QPTab
        | QPSpace
        | QPEscape S.ByteString

data QPC = QPCCR
         | QPCLF
         | QPCSpace
         | QPCTab
         | QPCPlain
         | QPCEscape
    deriving QPC -> QPC -> Bool
(QPC -> QPC -> Bool) -> (QPC -> QPC -> Bool) -> Eq QPC
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QPC -> QPC -> Bool
$c/= :: QPC -> QPC -> Bool
== :: QPC -> QPC -> Bool
$c== :: QPC -> QPC -> Bool
Eq

toQP :: Bool -- ^ text?
     -> L.ByteString
     -> [QP]
toQP :: Bool -> ByteString -> [QP]
toQP Bool
isText =
    ByteString -> [QP]
go
  where
    go :: ByteString -> [QP]
go ByteString
lbs =
        case ByteString -> Maybe (Word8, ByteString)
L.uncons ByteString
lbs of
            Maybe (Word8, ByteString)
Nothing -> []
            Just (Word8
c, ByteString
rest) ->
                case Word8 -> QPC
toQPC Word8
c of
                    QPC
QPCCR -> ByteString -> [QP]
go ByteString
rest
                    QPC
QPCLF -> QP
QPNewline QP -> [QP] -> [QP]
forall a. a -> [a] -> [a]
: ByteString -> [QP]
go ByteString
rest
                    QPC
QPCSpace -> QP
QPSpace QP -> [QP] -> [QP]
forall a. a -> [a] -> [a]
: ByteString -> [QP]
go ByteString
rest
                    QPC
QPCTab -> QP
QPTab QP -> [QP] -> [QP]
forall a. a -> [a] -> [a]
: ByteString -> [QP]
go ByteString
rest
                    QPC
QPCPlain ->
                        let (ByteString
x, ByteString
y) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
L.span ((QPC -> QPC -> Bool
forall a. Eq a => a -> a -> Bool
== QPC
QPCPlain) (QPC -> Bool) -> (Word8 -> QPC) -> Word8 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> QPC
toQPC) ByteString
lbs
                         in ByteString -> QP
QPPlain (ByteString -> ByteString
toStrict ByteString
x) QP -> [QP] -> [QP]
forall a. a -> [a] -> [a]
: ByteString -> [QP]
go ByteString
y
                    QPC
QPCEscape ->
                        let (ByteString
x, ByteString
y) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
L.span ((QPC -> QPC -> Bool
forall a. Eq a => a -> a -> Bool
== QPC
QPCEscape) (QPC -> Bool) -> (Word8 -> QPC) -> Word8 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> QPC
toQPC) ByteString
lbs
                         in ByteString -> QP
QPEscape (ByteString -> ByteString
toStrict ByteString
x) QP -> [QP] -> [QP]
forall a. a -> [a] -> [a]
: ByteString -> [QP]
go ByteString
y

    toStrict :: ByteString -> ByteString
toStrict = [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks

    toQPC :: Word8 -> QPC
    toQPC :: Word8 -> QPC
toQPC Word8
13 | Bool
isText = QPC
QPCCR
    toQPC Word8
10 | Bool
isText = QPC
QPCLF
    toQPC Word8
9 = QPC
QPCTab
    toQPC Word8
0x20 = QPC
QPCSpace
    toQPC Word8
46 = QPC
QPCEscape
    toQPC Word8
61 = QPC
QPCEscape
    toQPC Word8
w
        | Word8
33 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
w Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
126 = QPC
QPCPlain
        | Bool
otherwise = QPC
QPCEscape

buildQPs :: [QP] -> Builder
buildQPs :: [QP] -> Builder
buildQPs =
    Int -> [QP] -> Builder
go (Int
0 :: Int)
  where
    go :: Int -> [QP] -> Builder
go Int
_ [] = Builder
forall a. Monoid a => a
mempty
    go Int
currLine (QP
qp:[QP]
qps) =
        case QP
qp of
            QP
QPNewline -> ByteString -> Builder
copyByteString ByteString
"\r\n" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Int -> [QP] -> Builder
go Int
0 [QP]
qps
            QP
QPTab -> Builder -> Builder -> Builder
wsHelper (ByteString -> Builder
copyByteString ByteString
"=09") (Word8 -> Builder
fromWord8 Word8
9)
            QP
QPSpace -> Builder -> Builder -> Builder
wsHelper (ByteString -> Builder
copyByteString ByteString
"=20") (Word8 -> Builder
fromWord8 Word8
0x20)
            QPPlain ByteString
bs ->
                let toTake :: Int
toTake = Int
75 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
currLine
                    (ByteString
x, ByteString
y) = Int -> ByteString -> (ByteString, ByteString)
S.splitAt Int
toTake ByteString
bs
                    rest :: [QP]
rest
                        | ByteString -> Bool
S.null ByteString
y = [QP]
qps
                        | Bool
otherwise = ByteString -> QP
QPPlain ByteString
y QP -> [QP] -> [QP]
forall a. a -> [a] -> [a]
: [QP]
qps
                 in Int -> Builder -> Bool -> [QP] -> Builder
helper (ByteString -> Int
S.length ByteString
x) (ByteString -> Builder
copyByteString ByteString
x) (ByteString -> Bool
S.null ByteString
y) [QP]
rest
            QPEscape ByteString
bs ->
                let toTake :: Int
toTake = (Int
75 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
currLine) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3
                    (ByteString
x, ByteString
y) = Int -> ByteString -> (ByteString, ByteString)
S.splitAt Int
toTake ByteString
bs
                    rest :: [QP]
rest
                        | ByteString -> Bool
S.null ByteString
y = [QP]
qps
                        | Bool
otherwise = ByteString -> QP
QPEscape ByteString
y QP -> [QP] -> [QP]
forall a. a -> [a] -> [a]
: [QP]
qps
                 in if Int
toTake Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                        then ByteString -> Builder
copyByteString ByteString
"=\r\n" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Int -> [QP] -> Builder
go Int
0 (QP
qpQP -> [QP] -> [QP]
forall a. a -> [a] -> [a]
:[QP]
qps)
                        else Int -> Builder -> Bool -> [QP] -> Builder
helper (ByteString -> Int
S.length ByteString
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3) (ByteString -> Builder
escape ByteString
x) (ByteString -> Bool
S.null ByteString
y) [QP]
rest
      where
        escape :: ByteString -> Builder
escape =
            (Builder -> Word8 -> Builder) -> Builder -> ByteString -> Builder
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
S.foldl' Builder -> Word8 -> Builder
add Builder
forall a. Monoid a => a
mempty
          where
            add :: Builder -> Word8 -> Builder
add Builder
builder Word8
w =
                Builder
builder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
escaped
              where
                escaped :: Builder
escaped = Word8 -> Builder
fromWord8 Word8
61 Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
hex (Word8
w Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftR` Int
4)
                                       Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
hex (Word8
w Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
15)

        helper :: Int -> Builder -> Bool -> [QP] -> Builder
helper Int
added Builder
builder Bool
noMore [QP]
rest =
            Builder
builder' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Int -> [QP] -> Builder
go Int
newLine [QP]
rest
           where
             (Int
newLine, Builder
builder')
                | Bool -> Bool
not Bool
noMore Bool -> Bool -> Bool
|| (Int
added Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
currLine) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
75 =
                    (Int
0, Builder
builder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
copyByteString ByteString
"=\r\n")
                | Bool
otherwise = (Int
added Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
currLine, Builder
builder)

        wsHelper :: Builder -> Builder -> Builder
wsHelper Builder
enc Builder
raw
            | [QP] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [QP]
qps =
                if Int
currLine Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
73
                    then Builder
enc
                    else ByteString -> Builder
copyByteString ByteString
"\r\n=" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
enc
            | Bool
otherwise = Int -> Builder -> Bool -> [QP] -> Builder
helper Int
1 Builder
raw (Int
currLine Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
76) [QP]
qps

-- | The first parameter denotes whether the input should be treated as text.
-- If treated as text, then CRs will be stripped and LFs output as CRLFs. If
-- binary, then CRs and LFs will be escaped.
quotedPrintable :: Bool -> L.ByteString -> Builder
quotedPrintable :: Bool -> ByteString -> Builder
quotedPrintable Bool
isText = [QP] -> Builder
buildQPs ([QP] -> Builder) -> (ByteString -> [QP]) -> ByteString -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ByteString -> [QP]
toQP Bool
isText

hex :: Word8 -> Builder
hex :: Word8 -> Builder
hex Word8
x
    | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
10 = Word8 -> Builder
fromWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ Word8
x Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
48
    | Bool
otherwise = Word8 -> Builder
fromWord8 (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ Word8
x Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
55

encodeIfNeeded :: Text -> Builder
encodeIfNeeded :: Text -> Builder
encodeIfNeeded Text
t =
  if Text -> Bool
needsEncodedWord Text
t
  then Text -> Builder
encodedWord Text
t
  else Text -> Builder
fromText Text
t

needsEncodedWord :: Text -> Bool
needsEncodedWord :: Text -> Bool
needsEncodedWord = Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isAscii

encodedWord :: Text -> Builder
encodedWord :: Text -> Builder
encodedWord Text
t = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ ByteString -> Builder
fromByteString ByteString
"=?utf-8?Q?"
    , (Builder -> Word8 -> Builder) -> Builder -> ByteString -> Builder
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
S.foldl' Builder -> Word8 -> Builder
go Builder
forall a. Monoid a => a
mempty (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t
    , ByteString -> Builder
fromByteString ByteString
"?="
    ]
  where
    go :: Builder -> Word8 -> Builder
go Builder
front Word8
w = Builder
front Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
go' Word8
w
    go' :: Word8 -> Builder
go' Word8
32 = Word8 -> Builder
fromWord8 Word8
95 -- space
    go' Word8
95 = Word8 -> Builder
go'' Word8
95 -- _
    go' Word8
63 = Word8 -> Builder
go'' Word8
63 -- ?
    go' Word8
61 = Word8 -> Builder
go'' Word8
61 -- =

    -- The special characters from RFC 2822. Not all of these always give
    -- problems, but at least @[];"<>, gave problems with some mail servers
    -- when used in the 'name' part of an address.
    go' Word8
34 = Word8 -> Builder
go'' Word8
34 -- "
    go' Word8
40 = Word8 -> Builder
go'' Word8
40 -- (
    go' Word8
41 = Word8 -> Builder
go'' Word8
41 -- )
    go' Word8
44 = Word8 -> Builder
go'' Word8
44 -- ,
    go' Word8
46 = Word8 -> Builder
go'' Word8
46 -- .
    go' Word8
58 = Word8 -> Builder
go'' Word8
58 -- ;
    go' Word8
59 = Word8 -> Builder
go'' Word8
59 -- ;
    go' Word8
60 = Word8 -> Builder
go'' Word8
60 -- <
    go' Word8
62 = Word8 -> Builder
go'' Word8
62 -- >
    go' Word8
64 = Word8 -> Builder
go'' Word8
64 -- @
    go' Word8
91 = Word8 -> Builder
go'' Word8
91 -- [
    go' Word8
92 = Word8 -> Builder
go'' Word8
92 -- \
    go' 93 = go'' 93 -- ]
    go' Word8
w
        | Word8
33 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
w Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
126 = Word8 -> Builder
fromWord8 Word8
w
        | Bool
otherwise = Word8 -> Builder
go'' Word8
w
    go'' :: Word8 -> Builder
go'' Word8
w = Word8 -> Builder
fromWord8 Word8
61 Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
hex (Word8
w Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftR` Int
4)
                          Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
hex (Word8
w Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
15)

-- 57 bytes, when base64-encoded, becomes 76 characters.
-- Perform the encoding 57-bytes at a time, and then append a newline.
base64 :: L.ByteString -> Builder
base64 :: ByteString -> Builder
base64 ByteString
lbs
    | ByteString -> Bool
L.null ByteString
lbs = Builder
forall a. Monoid a => a
mempty
    | Bool
otherwise = ByteString -> Builder
fromByteString ByteString
x64 Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                  ByteString -> Builder
fromByteString ByteString
"\r\n" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
                  ByteString -> Builder
base64 ByteString
y
  where
    (ByteString
x', ByteString
y) = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt Int64
57 ByteString
lbs
    x :: ByteString
x = [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks ByteString
x'
    x64 :: ByteString
x64 = ByteString -> ByteString
Base64.encode ByteString
x