mime-mail 0.4.14 → 0.5.0
raw patch · 3 files changed
+168/−71 lines, 3 filesdep ~basenew-uploader
Dependency ranges changed: base
Files
- ChangeLog.md +8/−0
- Network/Mail/Mime.hs +157/−68
- mime-mail.cabal +3/−3
ChangeLog.md view
@@ -1,3 +1,11 @@+## 0.5++* Add support for inline images and multipart/related+* Add `filePart` and `filePartBS` for attachments+* Change `Part` data type (`Disposition` and `PartContent`)+* Remove `addAttachmentCid` and `addAttachmentBSCid` (replaced by `addImage`)+* Remove `getAttachmentPartBS` and `getAttachmentPart`+ ## 0.4.14 * Add `IsString` instance for `Address`
Network/Mail/Mime.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards #-} module Network.Mail.Mime ( -- * Datatypes Boundary (..)@@ -7,7 +7,11 @@ , Address (..) , Alternatives , Part (..)+ , PartContent (..)+ , Disposition (..) , Encoding (..)+ , InlineImage(..)+ , ImageContent(..) , Headers -- * Render a message , renderMail@@ -22,19 +26,23 @@ , simpleMail , simpleMail' , simpleMailInMemory+ , simpleMailWithImages -- * Utilities , addPart , addAttachment- , addAttachmentCid , addAttachments , addAttachmentBS- , addAttachmentBSCid , addAttachmentsBS , renderAddress , htmlPart , plainPart+ , filePart+ , filePartBS , randomString , quotedPrintable+ , relatedPart+ , addImage+ , mkImageParts ) where import qualified Data.ByteString.Lazy as L@@ -49,7 +57,7 @@ import System.Exit import System.FilePath (takeFileName) import qualified Data.ByteString.Base64 as Base64-import Control.Monad ((<=<), foldM, void)+import Control.Monad ((<=<), (>=>), foldM, void) import Control.Exception (throwIO, ErrorCall (ErrorCall)) import Data.List (intersperse) import qualified Data.Text.Lazy as LT@@ -139,18 +147,29 @@ , partEncoding :: Encoding -- | The filename for this part, if it is to be sent with an attachemnt -- disposition.- , partFilename :: Maybe Text+ , partDisposition :: Disposition , partHeaders :: Headers- , partContent :: L.ByteString+ , partContent :: PartContent } deriving (Eq, Show) +-- | NestedParts are for multipart-related: One HTML part and some inline images+data PartContent = PartContent L.ByteString | NestedParts [Part]+ deriving (Eq, Show)++data Disposition = AttachmentDisposition Text+ | InlineDisposition Text+ | DefaultDisposition+ deriving (Show, Eq)+ type Headers = [(S.ByteString, Text)]-type Pair = (Headers, Builder) +data Pair = Pair (Headers, Builder)+ | CompoundPair (Headers, [Pair])+ partToPair :: Part -> Pair-partToPair (Part contentType encoding disposition headers content) =- (headers', builder)+partToPair (Part contentType encoding disposition headers (PartContent content)) =+ Pair (headers', builder) where headers' = ((:) ("Content-Type", contentType))@@ -162,10 +181,12 @@ QuotedPrintableBinary -> (:) ("Content-Transfer-Encoding", "quoted-printable")) $ (case disposition of- Nothing -> id- Just fn ->- (:) ("Content-Disposition", "attachment; filename="- `T.append` fn))+ AttachmentDisposition fn ->+ (:) ("Content-Disposition", "attachment; filename=" `T.append` fn)+ InlineDisposition cid ->+ (:) ("Content-Disposition", "inline; filename=" `T.append` cid) . (:) ("Content-ID", "<" <> cid <> ">") . (:) ("Content-Location", cid)+ DefaultDisposition -> id+ ) $ headers builder = case encoding of@@ -173,7 +194,14 @@ Base64 -> base64 content QuotedPrintableText -> quotedPrintable True content QuotedPrintableBinary -> quotedPrintable False content+partToPair (Part contentType encoding disposition headers (NestedParts parts)) =+ CompoundPair (headers', pairs)+ where+ headers' = ("Content-Type", contentType):headers+ pairs = map partToPair parts ++-- This function merges sibling pairs into a multipart pair showPairs :: RandomGen g => Text -- ^ multipart type, eg mixed, alternative -> [Pair]@@ -182,7 +210,7 @@ showPairs _ [] _ = error "renderParts called with null parts" showPairs _ [pair] gen = (pair, gen) showPairs mtype parts gen =- ((headers, builder), gen')+ (Pair (headers, builder), gen') where (Boundary b, gen') = random gen headers =@@ -200,21 +228,56 @@ , showBoundEnd $ Boundary 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@(Pair _) gen = (pair, gen)+flattenCompoundPair (CompoundPair (hs, pairs)) gen =+ (Pair (headers, builder), gen')+ where+ (Boundary b, gen') = random gen+ headers =+ [ ("Content-Type", T.concat+ [ "multipart/related" , "; boundary=\"" , b , "\"" ])+ ]+ builder = mconcat+ [ mconcat $ intersperse (fromByteString "\n")+ $ map (showBoundPart $ Boundary b) pairs+ , 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+ -- parts is [Alternative], or [[Part]]+ -- reverse parts so attachments come at the end+ pairs :: [[Pair]]+ pairs = map (map partToPair) (reverse parts)++ (pairs1, g1) = helper2 g0 $ map (map flattenCompoundPair) pairs+ (pairs', g') = helper g1 $ map (showPairs "alternative") pairs1+ 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'++ -- new 2nd order helper+ helper2 :: g -> [[g -> (x, g)]] -> ([[x]], g)+ helper2 g [] = ([], g)+ helper2 g (x:xs) =+ let (b, g_) = helper g x -- original helper+ (bs, g__) = helper2 g_ xs+ in (b : bs, g__)++ (Pair (finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g' builder = mconcat [ mconcat addressHeaders , mconcat $ map showHeader headers@@ -271,8 +334,8 @@ sanitizeHeader :: Text -> Text sanitizeHeader = T.filter (not . isControl) -showBoundPart :: Boundary -> (Headers, Builder) -> Builder-showBoundPart (Boundary b) (headers, content) = mconcat+showBoundPart :: Boundary -> Pair -> Builder+showBoundPart (Boundary b) (Pair (headers, content)) = mconcat [ fromByteString "--" , fromText b , fromByteString "\n"@@ -331,7 +394,7 @@ -> IO (S.ByteString, S.ByteString) sendmailCustomCaptureOutput sm opts lbs = sendmailCustomAux True sm opts lbs -sendmailCustomAux :: Bool +sendmailCustomAux :: Bool -> FilePath -> [String] -> L.ByteString@@ -415,6 +478,39 @@ . addPart [plainPart plainBody, htmlPart htmlBody] $ mailFromToSubject from to subject ++data InlineImage = InlineImage {+ imageContentType :: Text+ , imageContent :: ImageContent+ , imageCID :: Text+ } deriving Show++data ImageContent = ImageFilePath FilePath | ImageByteString L.ByteString+ deriving 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 to from subject plainBody htmlBody images attachments = do+ inlineImageParts <- mkImageParts images+ addAttachments attachments+ . addPart [ plainPart plainBody+ , relatedPart ((htmlPart htmlBody):inlineImageParts) ]+ $ (emptyMail from) { mailTo = to, mailHeaders = [("Subject", subject)] }+ mailFromToSubject :: Address -- ^ from -> Address -- ^ to -> Text -- ^ subject@@ -429,45 +525,64 @@ -- To e.g. add a plain text body use -- > addPart [plainPart body] (emptyMail from) addPart :: Alternatives -> Mail -> Mail-addPart alt mail = mail { mailParts = mailParts mail ++ [alt] }+addPart alt mail = mail { mailParts = alt : mailParts mail } +-- | Add a 'Related' Part+relatedPart :: [Part] -> Part+relatedPart parts =+ Part "multipart/related" None DefaultDisposition [] (NestedParts parts)+ -- | Construct a UTF-8-encoded plain-text 'Part'. plainPart :: LT.Text -> Part-plainPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body+plainPart body = Part cType QuotedPrintableText DefaultDisposition []+ $ PartContent (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+htmlPart body = Part cType QuotedPrintableText DefaultDisposition []+ $ PartContent (LT.encodeUtf8 body) where cType = "text/html; charset=utf-8" +-- | Construct a BASE64-encoded file attachment 'Part'+--+-- Since 0.5.0+filePart :: Text -> FilePath -> IO Part+filePart ct fn = do+ content <- L.readFile fn+ return $ filePartBS ct (T.pack (takeFileName fn)) content++-- | Construct a BASE64-encoded file attachment 'Part'+--+-- Since 0.5.0+filePartBS :: Text -> Text -> L.ByteString -> Part+filePartBS ct filename content = Part ct Base64 (AttachmentDisposition filename) [] (PartContent content)+ -- | Add an attachment from a file and construct a 'Part'. addAttachment :: Text -> FilePath -> Mail -> IO Mail addAttachment ct fn mail = do- part <- getAttachmentPart ct fn+ part <- filePart ct fn return $ addPart [part] mail --- | Add an attachment from a file and construct a 'Part'--- with the specified content id in the Content-ID header.------ @since 0.4.12-addAttachmentCid :: Text -- ^ content type- -> FilePath -- ^ file name- -> Text -- ^ content ID- -> Mail- -> IO Mail-addAttachmentCid ct fn cid mail =- getAttachmentPart ct fn >>= (return.addToMail.addHeader) - where - addToMail part = addPart [part] mail- addHeader part = part { partHeaders = header:ph }- where ph = partHeaders part- header = ("Content-ID", T.concat ["<", cid, ">"])- addAttachments :: [(Text, FilePath)] -> Mail -> IO Mail addAttachments xs mail = foldM fun mail xs where fun m (c, f) = addAttachment c f m +-- | Add an inline image from a file and construct a 'Part'.+--+-- Since 0.5.0+addImage :: InlineImage -> IO Part+addImage InlineImage{..} = do+ content <- case imageContent of+ ImageFilePath fn -> L.readFile fn+ ImageByteString bs -> return bs+ return+ $ Part imageContentType Base64 (InlineDisposition imageCID) [] (PartContent content)++mkImageParts :: [InlineImage] -> IO [Part]+mkImageParts xs =+ mapM addImage xs+ -- | Add an attachment from a 'ByteString' and construct a 'Part'. -- -- Since 0.4.7@@ -475,23 +590,7 @@ -> Text -- ^ file name -> L.ByteString -- ^ content -> Mail -> Mail-addAttachmentBS ct fn content mail =- let part = getAttachmentPartBS ct fn content- in addPart [part] mail---- | @since 0.4.12-addAttachmentBSCid :: Text -- ^ content type- -> Text -- ^ file name- -> L.ByteString -- ^ content- -> Text -- ^ content ID- -> Mail -> Mail-addAttachmentBSCid ct fn content cid mail =- let part = addHeader $ getAttachmentPartBS ct fn content- in addPart [part] mail- where- addHeader part = part { partHeaders = header:ph }- where ph = partHeaders part- header = ("Content-ID", T.concat ["<", cid, ">"])+addAttachmentBS ct fn content mail = addPart [filePartBS ct fn content] mail -- | -- Since 0.4.7@@ -499,16 +598,6 @@ addAttachmentsBS xs mail = foldl fun mail xs where fun m (ct, fn, content) = addAttachmentBS ct fn content m -getAttachmentPartBS :: Text- -> Text- -> L.ByteString- -> Part-getAttachmentPartBS ct fn content = Part ct Base64 (Just fn) [] content--getAttachmentPart :: Text -> FilePath -> IO Part-getAttachmentPart ct fn = do- content <- L.readFile fn- return $ getAttachmentPartBS ct (T.pack (takeFileName fn)) content data QP = QPPlain S.ByteString | QPNewline
mime-mail.cabal view
@@ -1,12 +1,12 @@ Name: mime-mail-Version: 0.4.14+Version: 0.5.0 Synopsis: Compose MIME email messages. description: Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/mime-mail>. Homepage: http://github.com/snoyberg/mime-mail License: MIT License-file: LICENSE Author: Michael Snoyman <michael@snoyman.com>-Maintainer: Michael Snoyman <michael@snoyman.com>+Maintainer: Michael Snoyman <michael@snoyman.com>, Marek Suchánek <marek.suchanek@fit.cvut.cz> Category: Email Build-type: Simple extra-source-files: README.md@@ -18,7 +18,7 @@ Library Exposed-modules: Network.Mail.Mime- Build-depends: base >= 4 && < 5+ Build-depends: base >= 4.9 && < 5 , base64-bytestring >= 0.1 , process >= 1.0 , random >= 1.0