summaryrefslogtreecommitdiffstats
path: root/src/Network
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network')
-rw-r--r--src/Network/Mail/Mime.hs575
1 files changed, 575 insertions, 0 deletions
diff --git a/src/Network/Mail/Mime.hs b/src/Network/Mail/Mime.hs
new file mode 100644
index 0000000..8fd9fe1
--- /dev/null
+++ b/src/Network/Mail/Mime.hs
@@ -0,0 +1,575 @@
+{-# LANGUAGE CPP, OverloadedStrings #-}
+module Network.Mail.Mime
+ ( -- * Datatypes
+ Boundary (..)
+ , Mail (..)
+ , emptyMail
+ , Address (..)
+ , Alternatives
+ , Part (..)
+ , Encoding (..)
+ , Headers
+ -- * Render a message
+ , renderMail
+ , renderMail'
+ -- * Sending messages
+ , sendmail
+ , sendmailCustom
+ , renderSendMail
+ , renderSendMailCustom
+ -- * High-level 'Mail' creation
+ , simpleMail
+ , simpleMail'
+ , simpleMailInMemory
+ -- * Utilities
+ , addPart
+ , addAttachment
+ , addAttachments
+ , addAttachmentBS
+ , addAttachmentsBS
+ , htmlPart
+ , plainPart
+ , randomString
+ , quotedPrintable
+ ) where
+
+import qualified Data.ByteString.Lazy as L
+import Blaze.ByteString.Builder.Char.Utf8
+import Blaze.ByteString.Builder
+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)
+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)
+import Data.Word (Word8)
+import qualified Data.ByteString as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+
+-- | Generates a random sequence of alphanumerics of the given length.
+randomString :: RandomGen d => Int -> d -> (String, d)
+randomString len =
+ first (map toChar) . sequence' (replicate len (randomR (0, 61)))
+ where
+ sequence' [] g = ([], g)
+ sequence' (f:fs) g =
+ let (f', g') = f g
+ (fs', g'') = sequence' fs g'
+ in (f' : fs', g'')
+ toChar i
+ | i < 26 = toEnum $ i + fromEnum 'A'
+ | i < 52 = toEnum $ i + fromEnum 'a' - 26
+ | otherwise = toEnum $ i + fromEnum '0' - 52
+
+-- | MIME boundary between parts of a message.
+newtype Boundary = Boundary { unBoundary :: Text }
+ deriving (Eq, Show)
+instance Random Boundary where
+ randomR = const random
+ random = first (Boundary . T.pack) . randomString 10
+
+-- | An entire mail message.
+data Mail = Mail
+ { mailFrom :: Address
+ , mailTo :: [Address]
+ , mailCc :: [Address]
+ , mailBcc :: [Address]
+ -- | Other headers, excluding from, to, cc and bcc.
+ , 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.
+ , mailParts :: [Alternatives]
+ }
+ deriving Show
+
+-- | A mail message with the provided 'from' address and no other
+-- fields filled in.
+emptyMail :: Address -> Mail
+emptyMail from = Mail
+ { mailFrom = from
+ , mailTo = []
+ , mailCc = []
+ , mailBcc = []
+ , mailHeaders = []
+ , mailParts = []
+ }
+
+data Address = Address
+ { addressName :: Maybe Text
+ , addressEmail :: Text
+ }
+ deriving (Eq, Show)
+
+-- | How to encode a single part. You should use 'Base64' for binary data.
+data Encoding = None | Base64 | QuotedPrintableText | QuotedPrintableBinary
+ deriving (Eq, Show)
+
+-- | 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
+ { partType :: Text -- ^ content type
+ , partEncoding :: Encoding
+ -- | The filename for this part, if it is to be sent with an attachemnt
+ -- disposition.
+ , partFilename :: Maybe Text
+ , partHeaders :: Headers
+ , partContent :: L.ByteString
+ }
+ deriving (Eq, Show)
+
+type Headers = [(S.ByteString, Text)]
+type Pair = (Headers, Builder)
+
+partToPair :: Part -> Pair
+partToPair (Part contentType encoding disposition headers content) =
+ (headers', builder)
+ where
+ headers' =
+ (:) ("Content-Type", contentType)
+ $ (case encoding of
+ None -> id
+ Base64 -> (:) ("Content-Transfer-Encoding", "base64")
+ QuotedPrintableText ->
+ (:) ("Content-Transfer-Encoding", "quoted-printable")
+ QuotedPrintableBinary ->
+ (:) ("Content-Transfer-Encoding", "quoted-printable"))
+ $ (case disposition of
+ Nothing -> id
+ Just fn ->
+ (:) ("Content-Disposition", "attachment; filename="
+ `T.append` fn))
+ headers
+ builder =
+ case encoding of
+ None -> fromWriteList writeByteString $ L.toChunks content
+ Base64 -> base64 content
+ QuotedPrintableText -> quotedPrintable True content
+ QuotedPrintableBinary -> quotedPrintable False content
+
+showPairs :: RandomGen g
+ => Text -- ^ multipart type, eg mixed, alternative
+ -> [Pair]
+ -> g
+ -> (Pair, g)
+showPairs _ [] _ = error "renderParts called with null parts"
+showPairs _ [pair] gen = (pair, gen)
+showPairs mtype parts gen =
+ ((headers, builder), gen')
+ where
+ (Boundary b, gen') = random gen
+ headers =
+ [ ("Content-Type", T.concat
+ [ "multipart/"
+ , mtype
+ , "; boundary=\""
+ , b
+ , "\""
+ ])
+ ]
+ builder = mconcat
+ [ mconcat $ intersperse (fromByteString "\r\n")
+ $ map (showBoundPart $ Boundary b) parts
+ , showBoundEnd $ Boundary b
+ ]
+
+-- | Render a 'Mail' with a given 'RandomGen' for producing boundaries.
+renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g)
+renderMail g0 (Mail from to cc bcc headers parts) =
+ (toLazyByteString builder, g'')
+ where
+ addressHeaders = map showAddressHeader [("From", [from]), ("To", to), ("Cc", cc), ("Bcc", bcc)]
+ pairs = map (map partToPair) parts
+ (pairs', g') = helper g0 $ map (showPairs "alternative") pairs
+ helper :: g -> [g -> (x, g)] -> ([x], g)
+ helper g [] = ([], g)
+ helper g (x:xs) =
+ let (b, g_) = x g
+ (bs, g__) = helper g_ xs
+ in (b : bs, g__)
+ ((finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g'
+ builder = mconcat
+ [ mconcat addressHeaders
+ , mconcat $ map showHeader headers
+ , showHeader ("MIME-Version", "1.0")
+ , mconcat $ map showHeader finalHeaders
+ , fromByteString "\r\n"
+ , finalBuilder
+ ]
+
+showHeader :: (S.ByteString, Text) -> Builder
+showHeader (k, v) = mconcat
+ [ fromByteString k
+ , fromByteString ": "
+ , encodeIfNeeded v
+ , fromByteString "\r\n"
+ ]
+
+showAddressHeader :: (S.ByteString, [Address]) -> Builder
+showAddressHeader (k, as) =
+ if null as
+ then mempty
+ else mconcat
+ [ fromByteString k
+ , fromByteString ": "
+ , mconcat (intersperse (fromByteString ", ") . map showAddress $ as)
+ , fromByteString "\r\n"
+ ]
+
+-- |
+--
+-- Since 0.4.3
+showAddress :: Address -> Builder
+showAddress a = mconcat
+ [ maybe mempty ((`mappend` fromByteString " ") . encodedWord) (addressName a)
+ , fromByteString "<"
+ , fromText (addressEmail a)
+ , fromByteString ">"
+ ]
+
+showBoundPart :: Boundary -> (Headers, Builder) -> Builder
+showBoundPart (Boundary b) (headers, content) = mconcat
+ [ fromByteString "--"
+ , fromText b
+ , fromByteString "\r\n"
+ , mconcat $ map showHeader headers
+ , fromByteString "\r\n"
+ , content
+ ]
+
+showBoundEnd :: Boundary -> Builder
+showBoundEnd (Boundary b) = mconcat
+ [ fromByteString "\r\n--"
+ , fromText b
+ , fromByteString "--"
+ ]
+
+-- | Like 'renderMail', but generates a random boundary.
+renderMail' :: Mail -> IO L.ByteString
+renderMail' m = do
+ g <- getStdGen
+ let (lbs, g') = renderMail g m
+ setStdGen g'
+ return lbs
+
+-- | Send a fully-formed email message via the default sendmail
+-- executable with default options.
+sendmail :: L.ByteString -> IO ()
+sendmail = sendmailCustom sendmailPath ["-t"]
+
+sendmailPath :: String
+#ifdef MIME_MAIL_SENDMAIL_PATH
+sendmailPath = MIME_MAIL_SENDMAIL_PATH
+#else
+sendmailPath = "/usr/sbin/sendmail"
+#endif
+
+-- | Render an email message and send via the default sendmail
+-- executable with default options.
+renderSendMail :: Mail -> IO ()
+renderSendMail = sendmail <=< 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 sm opts lbs = do
+ (Just hin, _, _, phandle) <- createProcess $
+ (proc sm opts) { std_in = CreatePipe }
+ L.hPut hin lbs
+ hClose hin
+ exitCode <- waitForProcess phandle
+ case exitCode of
+ ExitSuccess -> return ()
+ _ -> throwIO $ ErrorCall ("sendmail exited with error code " ++ show 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 sm opts = sendmailCustom sm opts <=< 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 to from subject plainBody htmlBody attachments =
+ addAttachments attachments
+ . addPart [plainPart plainBody, htmlPart htmlBody]
+ $ mailFromToSubject from to 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' to from subject body = addPart [plainPart body]
+ $ mailFromToSubject from to 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 to from subject plainBody htmlBody attachments =
+ addAttachmentsBS attachments
+ . addPart [plainPart plainBody, htmlPart htmlBody]
+ $ mailFromToSubject from to subject
+
+mailFromToSubject :: Address -- ^ from
+ -> Address -- ^ to
+ -> Text -- ^ subject
+ -> Mail
+mailFromToSubject from to subject =
+ (emptyMail from) { mailTo = [to]
+ , mailHeaders = [("Subject", 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 alt mail = mail { mailParts = alt : mailParts mail }
+
+-- | Construct a UTF-8-encoded plain-text 'Part'.
+plainPart :: LT.Text -> Part
+plainPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body
+ where cType = "text/plain; charset=utf-8"
+
+-- | Construct a UTF-8-encoded html 'Part'.
+htmlPart :: LT.Text -> Part
+htmlPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body
+ where cType = "text/html; charset=utf-8"
+
+-- | Add an attachment from a file and construct a 'Part'.
+addAttachment :: Text -> FilePath -> Mail -> IO Mail
+addAttachment ct fn mail = do
+ content <- L.readFile fn
+ let part = Part ct Base64 (Just $ T.pack (takeFileName fn)) [] content
+ return $ addPart [part] mail
+
+addAttachments :: [(Text, FilePath)] -> Mail -> IO Mail
+addAttachments xs mail = foldM fun mail xs
+ where fun m (c, f) = addAttachment c f m
+
+-- | 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 ct fn content mail =
+ let part = Part ct Base64 (Just fn) [] content
+ in addPart [part] mail
+
+-- |
+-- Since 0.4.7
+addAttachmentsBS :: [(Text, Text, L.ByteString)] -> Mail -> Mail
+addAttachmentsBS xs mail = foldl fun mail xs
+ where fun m (ct, fn, content) = addAttachmentBS ct fn content m
+
+data QP = QPPlain S.ByteString
+ | QPNewline
+ | QPTab
+ | QPSpace
+ | QPEscape S.ByteString
+
+data QPC = QPCCR
+ | QPCLF
+ | QPCSpace
+ | QPCTab
+ | QPCPlain
+ | QPCEscape
+ deriving Eq
+
+toQP :: Bool -- ^ text?
+ -> L.ByteString
+ -> [QP]
+toQP isText =
+ go
+ where
+ go lbs =
+ case L.uncons lbs of
+ Nothing -> []
+ Just (c, rest) ->
+ case toQPC c of
+ QPCCR -> go rest
+ QPCLF -> QPNewline : go rest
+ QPCSpace -> QPSpace : go rest
+ QPCTab -> QPTab : go rest
+ QPCPlain ->
+ let (x, y) = L.span ((== QPCPlain) . toQPC) lbs
+ in QPPlain (toStrict x) : go y
+ QPCEscape ->
+ let (x, y) = L.span ((== QPCEscape) . toQPC) lbs
+ in QPEscape (toStrict x) : go y
+
+ toStrict = S.concat . L.toChunks
+
+ toQPC :: Word8 -> QPC
+ toQPC 13 | isText = QPCCR
+ toQPC 10 | isText = QPCLF
+ toQPC 9 = QPCTab
+ toQPC 0x20 = QPCSpace
+ toQPC 61 = QPCEscape
+ toQPC w
+ | 33 <= w && w <= 126 = QPCPlain
+ | otherwise = QPCEscape
+
+buildQPs :: [QP] -> Builder
+buildQPs =
+ go (0 :: Int)
+ where
+ go _ [] = mempty
+ go currLine (qp:qps) =
+ case qp of
+ QPNewline -> copyByteString "\r\n" `mappend` go 0 qps
+ QPTab -> wsHelper (copyByteString "=09") (fromWord8 9)
+ QPSpace -> wsHelper (copyByteString "=20") (fromWord8 0x20)
+ QPPlain bs ->
+ let toTake = 75 - currLine
+ (x, y) = S.splitAt toTake bs
+ rest
+ | S.null y = qps
+ | otherwise = QPPlain y : qps
+ in helper (S.length x) (copyByteString x) (S.null y) rest
+ QPEscape bs ->
+ let toTake = (75 - currLine) `div` 3
+ (x, y) = S.splitAt toTake bs
+ rest
+ | S.null y = qps
+ | otherwise = QPEscape y : qps
+ in if toTake == 0
+ then copyByteString "=\r\n" `mappend` go 0 (qp:qps)
+ else helper (S.length x * 3) (escape x) (S.null y) rest
+ where
+ escape =
+ S.foldl' add mempty
+ where
+ add builder w =
+ builder `mappend` escaped
+ where
+ escaped = fromWord8 61 `mappend` hex (w `shiftR` 4)
+ `mappend` hex (w .&. 15)
+
+ helper added builder noMore rest =
+ builder' `mappend` go newLine rest
+ where
+ (newLine, builder')
+ | not noMore || (added + currLine) >= 75 =
+ (0, builder `mappend` copyByteString "=\r\n")
+ | otherwise = (added + currLine, builder)
+
+ wsHelper enc raw
+ | null qps =
+ if currLine <= 73
+ then enc
+ else copyByteString "\r\n=" `mappend` enc
+ | otherwise = helper 1 raw (currLine < 76) 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 isText = buildQPs . toQP isText
+
+hex :: Word8 -> Builder
+hex x
+ | x < 10 = fromWord8 $ x + 48
+ | otherwise = fromWord8 $ x + 55
+
+encodeIfNeeded :: Text -> Builder
+encodeIfNeeded t =
+ if needsEncodedWord t
+ then encodedWord t
+ else fromText t
+
+needsEncodedWord :: Text -> Bool
+needsEncodedWord = not . T.all isAscii
+
+encodedWord :: Text -> Builder
+encodedWord t = mconcat
+ [ fromByteString "=?utf-8?Q?"
+ , S.foldl' go mempty $ TE.encodeUtf8 t
+ , fromByteString "?="
+ ]
+ where
+ go front w = front `mappend` go' w
+ go' 32 = fromWord8 95 -- space
+ go' 95 = go'' 95 -- _
+ go' 63 = go'' 63 -- ?
+ go' 61 = go'' 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' 34 = go'' 34 -- "
+ go' 40 = go'' 40 -- (
+ go' 41 = go'' 41 -- )
+ go' 44 = go'' 44 -- ,
+ go' 46 = go'' 46 -- .
+ go' 58 = go'' 58 -- ;
+ go' 59 = go'' 59 -- ;
+ go' 60 = go'' 60 -- <
+ go' 62 = go'' 62 -- >
+ go' 64 = go'' 64 -- @
+ go' 91 = go'' 91 -- [
+ go' 92 = go'' 92 -- \
+ go' 93 = go'' 93 -- ]
+ go' w
+ | 33 <= w && w <= 126 = fromWord8 w
+ | otherwise = go'' w
+ go'' w = fromWord8 61 `mappend` hex (w `shiftR` 4)
+ `mappend` hex (w .&. 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 lbs
+ | L.null lbs = mempty
+ | otherwise = fromByteString x64 `mappend`
+ fromByteString "\r\n" `mappend`
+ base64 y
+ where
+ (x', y) = L.splitAt 57 lbs
+ x = S.concat $ L.toChunks x'
+ x64 = Base64.encode x
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-25 01:19:55 +0000