diff --git a/Network/Mail/Mime.hs b/Network/Mail/Mime.hs --- a/Network/Mail/Mime.hs +++ b/Network/Mail/Mime.hs @@ -16,12 +16,12 @@ , simpleMail -- * Utilities , randomString + , quotedPrintable ) where import qualified Data.ByteString.Lazy as L import Blaze.ByteString.Builder.Char.Utf8 import Blaze.ByteString.Builder -import Blaze.ByteString.Builder.Internal.Write (fromWriteList) import Data.Monoid import System.Random import Control.Arrow @@ -34,6 +34,9 @@ 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) -- | Generates a random sequence of alphanumerics of the given length. randomString :: RandomGen d => Int -> d -> (String, d) @@ -58,7 +61,8 @@ -- | An entire mail message. data Mail = Mail - { mailHeaders :: [(String, String)] -- ^ All headers, including to, from subject. + { -- | All headers, including to, from subject. + mailHeaders :: [(String, String)] -- | A list of different sets of alternatives. As a concrete example: -- -- > mailParts = [ [textVersion, htmlVersion], [attachment1], [attachment1]] @@ -69,7 +73,7 @@ } -- | How to encode a single part. You should use 'Base64' for binary data. -data Encoding = None | Base64 +data Encoding = None | Base64 | QuotedPrintableText | QuotedPrintableBinary -- | Multiple alternative representations of the same data. For example, you -- could provide a plain-text and HTML version of a message. @@ -82,6 +86,7 @@ -- | The filename for this part, if it is to be sent with an attachemnt -- disposition. , partFilename :: Maybe String + , partHeaders :: [(String, String)] , partContent :: L.ByteString } @@ -89,24 +94,30 @@ type Pair = (Headers, Builder) partToPair :: Part -> Pair -partToPair (Part contentType encoding disposition content) = - (headers, builder) +partToPair (Part contentType encoding disposition headers content) = + (headers', builder) where - headers = + headers' = ((:) ("Content-Type", contentType)) $ (case encoding of None -> id - Base64 -> (:) ("Content-Transfer-Encoding", "base64")) + 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=" ++ fn)) - $ [] + $ headers builder = case encoding of - None -> fromWriteList writeByteString $ L.toChunks content - Base64 -> fromWriteList writeWord8 $ map (toEnum . fromEnum) + None -> fromWrite16List writeByteString $ L.toChunks content + Base64 -> fromWrite16List writeWord8 $ map (toEnum . fromEnum) $ encode $ L.unpack content + QuotedPrintableText -> quotedPrintable True content + QuotedPrintableBinary -> quotedPrintable False content showPairs :: RandomGen g => String -- ^ multipart type, eg mixed, alternative @@ -144,9 +155,9 @@ 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'') + let (b, g_) = x g + (bs, g__) = helper g_ xs + in (b : bs, g__) ((finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g' builder = mconcat [ mconcat $ map showHeader headers @@ -156,13 +167,20 @@ , finalBuilder ] +showHeader :: (String, String) -> Builder showHeader (k, v) = mconcat [ fromString k , fromByteString ": " - , fromString v + , v'' , fromByteString "\n" ] + where + v' = LT.pack v + v'' = if needsEncodedWord v' + then encodedWord v' + else fromLazyText v' +showBoundPart :: Boundary -> ([(String, String)], Builder) -> Builder showBoundPart (Boundary b) (headers, content) = mconcat [ fromByteString "--" , fromString b @@ -172,6 +190,7 @@ , content ] +showBoundEnd :: Boundary -> Builder showBoundEnd (Boundary b) = mconcat [ fromByteString "\n--" , fromString b @@ -224,11 +243,63 @@ , ("Subject", subject) ] , mailParts = - [ Part "text/plain; charset=utf-8" None Nothing + [ Part "text/plain; charset=utf-8" QuotedPrintableText Nothing [] $ LT.encodeUtf8 plainBody - , Part "text/html; charset=utf-8" None Nothing + , Part "text/html; charset=utf-8" QuotedPrintableText Nothing [] $ LT.encodeUtf8 htmlBody ] : - (map (\(ct, fn, content) -> [Part ct Base64 (Just fn) content]) - as) + (map (\(ct, fn, content) -> + [Part ct Base64 (Just fn) [] content]) as) } + +-- | 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 lbs = + fst $ L.foldl' go (mempty, 0 :: Int) lbs + where + go (front, lineLen) w = + (front `mappend` b, lineLen') + where + (lineLen', b) + | w == 13 && isText = (lineLen, mempty) -- CR + | w == 10 && isText = (0, fromByteString "\r\n") + | w == 61 = helper 3 $ fromByteString "=3D" + | 33 <= w && w <= 126 = helper 1 $ fromWord8 w + | (w == 9 || w == 0x20) && lineLen < 75 = helper 1 $ fromWord8 w + | w == 9 = (0, fromByteString "=09=\r\n") + | w == 0x20 = (0, fromByteString "=20=\r\n") + | otherwise = helper 3 escaped + helper newLen bs + | newLen + lineLen > 78 = + (0, bs `mappend` fromByteString "=\r\n") + | otherwise = (newLen + lineLen, bs) + escaped = fromWord8 61 `mappend` hex (w `shiftR` 4) + `mappend` hex (w .&. 15) + +hex :: Word8 -> Builder +hex x + | x < 10 = fromWord8 $ x + 48 + | otherwise = fromWord8 $ x + 55 + +needsEncodedWord :: LT.Text -> Bool +needsEncodedWord = not . LT.all isAscii + +encodedWord :: LT.Text -> Builder +encodedWord t = mconcat + [ fromByteString "=?utf-8?Q?" + , L.foldl' go mempty $ LT.encodeUtf8 t + , fromByteString "?=" + ] + where + go front w = front `mappend` go' w + go' 32 = fromWord8 95 + go' 95 = go'' 95 + go' 63 = go'' 63 + go' 61 = go'' 61 + go' w + | 33 <= w && w <= 126 = fromWord8 w + | otherwise = go'' w + go'' w = fromWord8 61 `mappend` hex (w `shiftR` 4) + `mappend` hex (w .&. 15) diff --git a/mime-mail.cabal b/mime-mail.cabal --- a/mime-mail.cabal +++ b/mime-mail.cabal @@ -1,5 +1,5 @@ Name: mime-mail -Version: 0.0.0.4 +Version: 0.1.0 Synopsis: Compose MIME email messages. Description: This package provides some high-level datatypes for declaring MIME email messages, functions for automatically composing these into bytestrings, and the ability to send bytestrings via the sendmail executable. You can also use any other library you wish to send via different methods, eg directly to SMTP. Homepage: http://github.com/snoyberg/mime-mail @@ -20,7 +20,7 @@ , dataenc >= 0.13.0.4 && < 0.14 , process >= 1.0 && < 1.1 , random >= 1.0 && < 1.1 - , blaze-builder >= 0.2.1 && < 0.3 + , blaze-builder >= 0.2 && < 0.3 , bytestring >= 0.9.1 && < 0.10 , text >= 0.7 && < 0.12