{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards #-}
module Network.Mail.Mime
(
Boundary (..)
, Mail (..)
, emptyMail
, Address (..)
, Alternatives
, Part (..)
, PartContent (..)
, Disposition (..)
, Encoding (..)
, InlineImage(..)
, ImageContent(..)
, Headers
, renderMail
, renderMail'
, sendmail
, sendmailCustom
, sendmailCustomCaptureOutput
, renderSendMail
, renderSendMailCustom
, simpleMail
, simpleMail'
, simpleMailInMemory
, simpleMailWithImages
, 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
randomString :: RandomGen d => Int -> d -> (String, d)
randomString :: Int -> d -> (String, d)
randomString len :: 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 (0, 61)))
where
sequence' :: [b -> (a, b)] -> b -> ([a], b)
sequence' [] g :: b
g = ([], b
g)
sequence' (f :: b -> (a, b)
f:fs :: [b -> (a, b)]
fs) g :: b
g =
let (f' :: a
f', g' :: b
g') = b -> (a, b)
f b
g
(fs' :: [a]
fs', g'' :: 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 i :: Int
i
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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 'A'
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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 'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
- 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 '0' Int -> Int -> Int
forall a. Num a => a -> a -> a
- 52
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 10
data Mail = Mail
{ Mail -> Address
mailFrom :: Address
, Mail -> [Address]
mailTo :: [Address]
, Mail -> [Address]
mailCc :: [Address]
, Mail -> [Address]
mailBcc :: [Address]
, :: Headers
, 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
emptyMail :: Address -> Mail
emptyMail :: Address -> Mail
emptyMail from :: 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)
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
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)
type Alternatives = [Part]
data Part = Part
{ Part -> Text
partType :: Text
, Part -> Encoding
partEncoding :: Encoding
, Part -> Disposition
partDisposition :: Disposition
, :: 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)
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)
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)
type = [(S.ByteString, Text)]
data Pair = Pair (Headers, Builder)
| CompoundPair (Headers, [Pair])
partToPair :: Part -> Pair
partToPair :: Part -> Pair
partToPair (Part contentType :: Text
contentType encoding :: Encoding
encoding disposition :: Disposition
disposition headers :: Headers
headers (PartContent content :: ByteString
content)) =
(Headers, Builder) -> Pair
Pair (Headers
headers', Builder
builder)
where
headers' :: Headers
headers' =
((:) ("Content-Type", Text
contentType))
(Headers -> Headers) -> Headers -> Headers
forall a b. (a -> b) -> a -> b
$ (case Encoding
encoding of
None -> Headers -> Headers
forall a. a -> a
id
Base64 -> (:) ("Content-Transfer-Encoding", "base64")
QuotedPrintableText ->
(:) ("Content-Transfer-Encoding", "quoted-printable")
QuotedPrintableBinary ->
(:) ("Content-Transfer-Encoding", "quoted-printable"))
(Headers -> Headers) -> Headers -> Headers
forall a b. (a -> b) -> a -> b
$ (case Disposition
disposition of
AttachmentDisposition fn :: Text
fn ->
(:) ("Content-Disposition", "attachment; filename=" Text -> Text -> Text
`T.append` Text
fn)
InlineDisposition cid :: Text
cid ->
(:) ("Content-Disposition", "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
. (:) ("Content-ID", "<" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ">") (Headers -> Headers) -> (Headers -> Headers) -> Headers -> Headers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) ("Content-Location", Text
cid)
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
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
Base64 -> ByteString -> Builder
base64 ByteString
content
QuotedPrintableText -> Bool -> ByteString -> Builder
quotedPrintable Bool
True ByteString
content
QuotedPrintableBinary -> Bool -> ByteString -> Builder
quotedPrintable Bool
False ByteString
content
partToPair (Part contentType :: Text
contentType encoding :: Encoding
encoding disposition :: Disposition
disposition headers :: Headers
headers (NestedParts parts :: Alternatives
parts)) =
(Headers, [Pair]) -> Pair
CompoundPair (Headers
headers', [Pair]
pairs)
where
headers' :: Headers
headers' = ("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
showPairs :: RandomGen g
=> Text
-> [Pair]
-> g
-> (Pair, g)
showPairs :: Text -> [Pair] -> g -> (Pair, g)
showPairs _ [] _ = String -> (Pair, g)
forall a. HasCallStack => String -> a
error "renderParts called with null parts"
showPairs _ [pair :: Pair
pair] gen :: g
gen = (Pair
pair, g
gen)
showPairs mtype :: Text
mtype parts :: [Pair]
parts gen :: g
gen =
((Headers, Builder) -> Pair
Pair (Headers
headers, Builder
builder), g
gen')
where
(Boundary b :: Text
b, gen' :: g
gen') = g -> (Boundary, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random g
gen
headers :: Headers
headers =
[ ("Content-Type", [Text] -> Text
T.concat
[ "multipart/"
, Text
mtype
, "; boundary=\""
, Text
b
, "\""
])
]
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 "\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
]
flattenCompoundPair :: RandomGen g => Pair -> g -> (Pair, g)
flattenCompoundPair :: Pair -> g -> (Pair, g)
flattenCompoundPair pair :: Pair
pair@(Pair _) gen :: g
gen = (Pair
pair, g
gen)
flattenCompoundPair (CompoundPair (hs :: Headers
hs, pairs :: [Pair]
pairs)) gen :: g
gen =
((Headers, Builder) -> Pair
Pair (Headers
headers, Builder
builder), g
gen')
where
(Boundary b :: Text
b, gen' :: g
gen') = g -> (Boundary, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random g
gen
headers :: Headers
headers =
[ ("Content-Type", [Text] -> Text
T.concat
[ "multipart/related" , "; boundary=\"" , Text
b , "\"" ])
]
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 "\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
]
renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g)
renderMail :: g -> Mail -> (ByteString, g)
renderMail g0 :: g
g0 (Mail from :: Address
from to :: [Address]
to cc :: [Address]
cc bcc :: [Address]
bcc headers :: Headers
headers parts :: [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 [("From", [Address
from]), ("To", [Address]
to), ("Cc", [Address]
cc), ("Bcc", [Address]
bcc)]
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)
(pairs1 :: [[Pair]]
pairs1, g1 :: 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
(pairs' :: [Pair]
pairs', g' :: 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 "alternative") [[Pair]]
pairs1
helper :: g -> [g -> (x, g)] -> ([x], g)
helper :: g -> [g -> (x, g)] -> ([x], g)
helper g :: g
g [] = ([], g
g)
helper g :: g
g (x :: g -> (x, g)
x:xs :: [g -> (x, g)]
xs) =
let (b :: x
b, g_ :: g
g_) = g -> (x, g)
x g
g
(bs :: [x]
bs, g__ :: 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__)
helper2 :: g -> [[g -> (x, g)]] -> ([[x]], g)
helper2 :: g -> [[g -> (x, g)]] -> ([[x]], g)
helper2 g :: g
g [] = ([], g
g)
helper2 g :: g
g (x :: [g -> (x, g)]
x:xs :: [[g -> (x, g)]]
xs) =
let (b :: [x]
b, g_ :: g
g_) = g -> [g -> (x, g)] -> ([x], g)
forall g x. g -> [g -> (x, g)] -> ([x], g)
helper g
g [g -> (x, g)]
x
(bs :: [[x]]
bs, g__ :: 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 (finalHeaders :: Headers
finalHeaders, finalBuilder :: Builder
finalBuilder), g'' :: g
g'') = Text -> [Pair] -> g -> (Pair, g)
forall g. RandomGen g => Text -> [Pair] -> g -> (Pair, g)
showPairs "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 ("MIME-Version", "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 "\n"
, Builder
finalBuilder
]
renderAddress :: Address -> Text
renderAddress :: Address -> Text
renderAddress address :: 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
sanitizeFieldName :: S.ByteString -> S.ByteString
sanitizeFieldName :: ByteString -> ByteString
sanitizeFieldName = (Word8 -> Bool) -> ByteString -> ByteString
S.filter (\w :: Word8
w -> Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= 33 Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= 126 Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= 58)
showHeader :: (S.ByteString, Text) -> Builder
(k :: ByteString
k, v :: Text
v) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
[ ByteString -> Builder
fromByteString (ByteString -> ByteString
sanitizeFieldName ByteString
k)
, ByteString -> Builder
fromByteString ": "
, Text -> Builder
encodeIfNeeded (Text -> Text
sanitizeHeader Text
v)
, ByteString -> Builder
fromByteString "\n"
]
showAddressHeader :: (S.ByteString, [Address]) -> Builder
(k :: ByteString
k, as :: [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 ": "
, [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (ByteString -> Builder
fromByteString ", ") ([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 "\n"
]
showAddress :: Address -> Builder
showAddress :: Address -> Builder
showAddress a :: 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 " ") (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 "<"
, 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 ">"
]
sanitizeHeader :: Text -> Text
= (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 b :: Text
b) (Pair (headers :: Headers
headers, content :: Builder
content)) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
[ ByteString -> Builder
fromByteString "--"
, Text -> Builder
fromText Text
b
, ByteString -> Builder
fromByteString "\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 "\n"
, Builder
content
]
showBoundEnd :: Boundary -> Builder
showBoundEnd :: Boundary -> Builder
showBoundEnd (Boundary b :: Text
b) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
[ ByteString -> Builder
fromByteString "\n--"
, Text -> Builder
fromText Text
b
, ByteString -> Builder
fromByteString "--"
]
renderMail' :: Mail -> IO L.ByteString
renderMail' :: Mail -> IO ByteString
renderMail' m :: Mail
m = do
StdGen
g <- IO StdGen
getStdGen
let (lbs :: ByteString
lbs, g' :: StdGen
g') = StdGen -> Mail -> (ByteString, StdGen)
forall g. RandomGen g => g -> Mail -> (ByteString, g)
renderMail StdGen
g Mail
m
StdGen -> IO ()
setStdGen StdGen
g'
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
lbs
sendmail :: L.ByteString -> IO ()
sendmail :: ByteString -> IO ()
sendmail = String -> [String] -> ByteString -> IO ()
sendmailCustom String
sendmailPath ["-t"]
sendmailPath :: String
#ifdef MIME_MAIL_SENDMAIL_PATH
sendmailPath = MIME_MAIL_SENDMAIL_PATH
#else
sendmailPath :: String
sendmailPath = "/usr/sbin/sendmail"
#endif
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'
sendmailCustom :: FilePath
-> [String]
-> L.ByteString
-> IO ()
sendmailCustom :: String -> [String] -> ByteString -> IO ()
sendmailCustom sm :: String
sm opts :: [String]
opts lbs :: 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
sendmailCustomCaptureOutput :: FilePath
-> [String]
-> L.ByteString
-> IO (S.ByteString, S.ByteString)
sendmailCustomCaptureOutput :: String -> [String] -> ByteString -> IO (ByteString, ByteString)
sendmailCustomCaptureOutput sm :: String
sm opts :: [String]
opts lbs :: 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 captureOut :: Bool
captureOut sm :: String
sm opts :: [String]
opts lbs :: 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 hin :: Handle
hin, mHOut :: Maybe Handle
mHOut, mHErr :: Maybe Handle
mHErr, phandle :: 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
(Nothing, Nothing) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Just hOut :: Handle
hOut, Just hErr :: 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
_ -> String -> IO ()
forall a. HasCallStack => String -> a
error "error in sendmailCustomAux: missing a handle"
ExitCode
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
phandle
case ExitCode
exitCode of
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)
_ -> 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 ("sendmail exited with error code " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
exitCode)
renderSendMailCustom :: FilePath
-> [String]
-> Mail
-> IO ()
renderSendMailCustom :: String -> [String] -> Mail -> IO ()
renderSendMailCustom sm :: String
sm opts :: [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'
simpleMail :: Address
-> Address
-> Text
-> LT.Text
-> LT.Text
-> [(Text, FilePath)]
-> IO Mail
simpleMail :: Address
-> Address -> Text -> Text -> Text -> [(Text, String)] -> IO Mail
simpleMail to :: Address
to from :: Address
from subject :: Text
subject plainBody :: Text
plainBody htmlBody :: Text
htmlBody attachments :: [(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
simpleMail' :: Address
-> Address
-> Text
-> LT.Text
-> Mail
simpleMail' :: Address -> Address -> Text -> Text -> Mail
simpleMail' to :: Address
to from :: Address
from subject :: Text
subject body :: 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
simpleMailInMemory :: Address
-> Address
-> Text
-> LT.Text
-> LT.Text
-> [(Text, Text, L.ByteString)]
-> Mail
simpleMailInMemory :: Address
-> Address
-> Text
-> Text
-> Text
-> [(Text, Text, ByteString)]
-> Mail
simpleMailInMemory to :: Address
to from :: Address
from subject :: Text
subject plainBody :: Text
plainBody htmlBody :: Text
htmlBody attachments :: [(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
simpleMailWithImages :: [Address]
-> Address
-> Text
-> LT.Text
-> LT.Text
-> [InlineImage]
-> [(Text, FilePath)]
-> IO Mail
simpleMailWithImages :: [Address]
-> Address
-> Text
-> Text
-> Text
-> [InlineImage]
-> [(Text, String)]
-> IO Mail
simpleMailWithImages to :: [Address]
to from :: Address
from subject :: Text
subject plainBody :: Text
plainBody htmlBody :: Text
htmlBody images :: [InlineImage]
images attachments :: [(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 = [("Subject", Text
subject)] }
mailFromToSubject :: Address
-> Address
-> Text
-> Mail
mailFromToSubject :: Address -> Address -> Text -> Mail
mailFromToSubject from :: Address
from to :: Address
to subject :: Text
subject =
(Address -> Mail
emptyMail Address
from) { mailTo :: [Address]
mailTo = [Address
to]
, mailHeaders :: Headers
mailHeaders = [("Subject", Text
subject)]
}
addPart :: Alternatives -> Mail -> Mail
addPart :: Alternatives -> Mail -> Mail
addPart alt :: Alternatives
alt mail :: Mail
mail = Mail
mail { mailParts :: [Alternatives]
mailParts = Alternatives
alt Alternatives -> [Alternatives] -> [Alternatives]
forall a. a -> [a] -> [a]
: Mail -> [Alternatives]
mailParts Mail
mail }
relatedPart :: [Part] -> Part
relatedPart :: Alternatives -> Part
relatedPart parts :: Alternatives
parts =
Text -> Encoding -> Disposition -> Headers -> PartContent -> Part
Part "multipart/related" Encoding
None Disposition
DefaultDisposition [] (Alternatives -> PartContent
NestedParts Alternatives
parts)
plainPart :: LT.Text -> Part
plainPart :: Text -> Part
plainPart body :: 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/plain; charset=utf-8"
htmlPart :: LT.Text -> Part
htmlPart :: Text -> Part
htmlPart body :: 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/html; charset=utf-8"
filePart :: Text -> FilePath -> IO Part
filePart :: Text -> String -> IO Part
filePart ct :: Text
ct fn :: 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
filePartBS :: Text -> Text -> L.ByteString -> Part
filePartBS :: Text -> Text -> ByteString -> Part
filePartBS ct :: Text
ct filename :: Text
filename content :: ByteString
content = Text -> Encoding -> Disposition -> Headers -> PartContent -> Part
Part Text
ct Encoding
Base64 (Text -> Disposition
AttachmentDisposition Text
filename) [] (ByteString -> PartContent
PartContent ByteString
content)
addAttachment :: Text -> FilePath -> Mail -> IO Mail
addAttachment :: Text -> String -> Mail -> IO Mail
addAttachment ct :: Text
ct fn :: String
fn mail :: 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 xs :: [(Text, String)]
xs mail :: 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 m :: Mail
m (c :: Text
c, f :: String
f) = Text -> String -> Mail -> IO Mail
addAttachment Text
c String
f Mail
m
addImage :: InlineImage -> IO Part
addImage :: InlineImage -> IO Part
addImage InlineImage{..} = do
ByteString
content <- case ImageContent
imageContent of
ImageFilePath fn :: String
fn -> String -> IO ByteString
L.readFile String
fn
ImageByteString bs :: 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 xs :: [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
addAttachmentBS :: Text
-> Text
-> L.ByteString
-> Mail -> Mail
addAttachmentBS :: Text -> Text -> ByteString -> Mail -> Mail
addAttachmentBS ct :: Text
ct fn :: Text
fn content :: ByteString
content mail :: Mail
mail = Alternatives -> Mail -> Mail
addPart [Text -> Text -> ByteString -> Part
filePartBS Text
ct Text
fn ByteString
content] Mail
mail
addAttachmentsBS :: [(Text, Text, L.ByteString)] -> Mail -> Mail
addAttachmentsBS :: [(Text, Text, ByteString)] -> Mail -> Mail
addAttachmentsBS xs :: [(Text, Text, ByteString)]
xs mail :: 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 m :: Mail
m (ct :: Text
ct, fn :: Text
fn, content :: 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
-> L.ByteString
-> [QP]
toQP :: Bool -> ByteString -> [QP]
toQP isText :: Bool
isText =
ByteString -> [QP]
go
where
go :: ByteString -> [QP]
go lbs :: ByteString
lbs =
case ByteString -> Maybe (Word8, ByteString)
L.uncons ByteString
lbs of
Nothing -> []
Just (c :: Word8
c, rest :: ByteString
rest) ->
case Word8 -> QPC
toQPC Word8
c of
QPCCR -> ByteString -> [QP]
go ByteString
rest
QPCLF -> QP
QPNewline QP -> [QP] -> [QP]
forall a. a -> [a] -> [a]
: ByteString -> [QP]
go ByteString
rest
QPCSpace -> QP
QPSpace QP -> [QP] -> [QP]
forall a. a -> [a] -> [a]
: ByteString -> [QP]
go ByteString
rest
QPCTab -> QP
QPTab QP -> [QP] -> [QP]
forall a. a -> [a] -> [a]
: ByteString -> [QP]
go ByteString
rest
QPCPlain ->
let (x :: ByteString
x, y :: 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
QPCEscape ->
let (x :: ByteString
x, y :: 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 13 | Bool
isText = QPC
QPCCR
toQPC 10 | Bool
isText = QPC
QPCLF
toQPC 9 = QPC
QPCTab
toQPC 0x20 = QPC
QPCSpace
toQPC 46 = QPC
QPCEscape
toQPC 61 = QPC
QPCEscape
toQPC w :: Word8
w
| 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
<= 126 = QPC
QPCPlain
| Bool
otherwise = QPC
QPCEscape
buildQPs :: [QP] -> Builder
buildQPs :: [QP] -> Builder
buildQPs =
Int -> [QP] -> Builder
go (0 :: Int)
where
go :: Int -> [QP] -> Builder
go _ [] = Builder
forall a. Monoid a => a
mempty
go currLine :: Int
currLine (qp :: QP
qp:qps :: [QP]
qps) =
case QP
qp of
QPNewline -> ByteString -> Builder
copyByteString "\r\n" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Int -> [QP] -> Builder
go 0 [QP]
qps
QPTab -> Builder -> Builder -> Builder
wsHelper (ByteString -> Builder
copyByteString "=09") (Word8 -> Builder
fromWord8 9)
QPSpace -> Builder -> Builder -> Builder
wsHelper (ByteString -> Builder
copyByteString "=20") (Word8 -> Builder
fromWord8 0x20)
QPPlain bs :: ByteString
bs ->
let toTake :: Int
toTake = 75 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
currLine
(x :: ByteString
x, y :: 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 bs :: ByteString
bs ->
let toTake :: Int
toTake = (75 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
currLine) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 3
(x :: ByteString
x, y :: 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
== 0
then ByteString -> Builder
copyByteString "=\r\n" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Int -> [QP] -> Builder
go 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
* 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
builder w :: Word8
w =
Builder
builder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
escaped
where
escaped :: Builder
escaped = Word8 -> Builder
fromWord8 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` 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
.&. 15)
helper :: Int -> Builder -> Bool -> [QP] -> Builder
helper added :: Int
added builder :: Builder
builder noMore :: Bool
noMore rest :: [QP]
rest =
Builder
builder' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Int -> [QP] -> Builder
go Int
newLine [QP]
rest
where
(newLine :: Int
newLine, builder' :: 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
>= 75 =
(0, Builder
builder Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
copyByteString "=\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 enc :: Builder
enc raw :: 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
<= 73
then Builder
enc
else ByteString -> Builder
copyByteString "\r\n=" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
enc
| Bool
otherwise = Int -> Builder -> Bool -> [QP] -> Builder
helper 1 Builder
raw (Int
currLine Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 76) [QP]
qps
quotedPrintable :: Bool -> L.ByteString -> Builder
quotedPrintable :: Bool -> ByteString -> Builder
quotedPrintable isText :: 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 x :: Word8
x
| Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< 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
+ 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
+ 55
encodeIfNeeded :: Text -> Builder
encodeIfNeeded :: Text -> Builder
encodeIfNeeded t :: 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 t :: Text
t = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
[ ByteString -> Builder
fromByteString "=?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 "?="
]
where
go :: Builder -> Word8 -> Builder
go front :: Builder
front w :: Word8
w = Builder
front Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Word8 -> Builder
go' Word8
w
go' :: Word8 -> Builder
go' 32 = Word8 -> Builder
fromWord8 95
go' 95 = Word8 -> Builder
go'' 95
go' 63 = Word8 -> Builder
go'' 63
go' 61 = Word8 -> Builder
go'' 61
go' 34 = Word8 -> Builder
go'' 34
go' 40 = Word8 -> Builder
go'' 40
go' 41 = Word8 -> Builder
go'' 41
go' 44 = Word8 -> Builder
go'' 44
go' 46 = Word8 -> Builder
go'' 46
go' 58 = Word8 -> Builder
go'' 58
go' 59 = Word8 -> Builder
go'' 59
go' 60 = Word8 -> Builder
go'' 60
go' 62 = Word8 -> Builder
go'' 62
go' 64 = Word8 -> Builder
go'' 64
go' 91 = Word8 -> Builder
go'' 91
go' 92 = Word8 -> Builder
go'' 92
go' 93 = go'' 93
go' w :: Word8
w
| 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
<= 126 = Word8 -> Builder
fromWord8 Word8
w
| Bool
otherwise = Word8 -> Builder
go'' Word8
w
go'' :: Word8 -> Builder
go'' w :: Word8
w = Word8 -> Builder
fromWord8 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` 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
.&. 15)
base64 :: L.ByteString -> Builder
base64 :: ByteString -> Builder
base64 lbs :: 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 "\r\n" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
ByteString -> Builder
base64 ByteString
y
where
(x' :: ByteString
x', y :: ByteString
y) = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt 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