purebred-email 0.3.1 → 0.4

raw patch · 17 files changed

+548/−206 lines, 17 filesdep +hedgehogdep +tasty-hedgehogPVP ok

version bump matches the API change (PVP)

Dependencies added: hedgehog, tasty-hedgehog

API changes (from Hackage documentation)

Files

• purebred-email.cabal +9/−5
• src/Data/MIME.hs +95/−74
• src/Data/MIME/Base64.hs +7/−1
• src/Data/MIME/EncodedWord.hs +63/−22
• src/Data/MIME/QuotedPrintable.hs +12/−7
• src/Data/MIME/TransferEncoding.hs +1/−1
• src/Data/RFC5322.hs +159/−36
• src/Data/RFC5322/Address/Text.hs +14/−4
• src/Data/RFC5322/Internal.hs +5/−4
• tests/EncodedWord.hs +22/−0
• tests/Generator.hs +2/−2
• tests/Headers.hs +12/−12
• tests/MIME.hs +30/−0
• tests/Message.hs +71/−37
• tests/Parser.hs +42/−0
• tests/Test.hs +2/−1
• tests/golden/multipart.golden +2/−0

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                purebred-email-version:             0.3.1+version:             0.4 synopsis:            types and parser for email messages (including MIME) description:   The purebred email library.  RFC 5322, MIME, etc.@@ -85,10 +85,12 @@ test-suite tests   type: exitcode-stdio-1.0   default-language:    Haskell2010+  ghc-options: -Wall -Wredundant-constraints   hs-source-dirs: tests   main-is: Test.hs   other-modules:     ContentTransferEncodings+    , EncodedWord     , Headers     , MIME     , Generator@@ -96,21 +98,23 @@     , Message   build-depends:     base+    , attoparsec     , bytestring     , lens     , text     , purebred-email+    , case-insensitive >= 1.2 && < 1.3+    , semigroups >= 0.16+    , time      , tasty+    , tasty-hedgehog     , tasty-quickcheck     , tasty-hunit     , tasty-golden-    , attoparsec+    , hedgehog     , QuickCheck     , quickcheck-instances-    , case-insensitive >= 1.2 && < 1.3-    , semigroups >= 0.16-    , time  executable purebred-email-parse   if !flag(demos)

@@ -80,10 +80,6 @@   , filename   , filenameParameter -  -- ** Serialisation-  , renderMessage-  , buildMessage-   -- ** Mail creation   -- *** Common use cases   , createTextPlainMessage@@ -97,6 +93,8 @@   , headerCC   , headerBCC   , headerDate+  , headerSubject+  , headerText   , replyHeaderReferences    -- * Re-exports@@ -108,7 +106,8 @@   ) where  import Control.Applicative-import Data.List.NonEmpty (NonEmpty, fromList)+import Data.Foldable (fold)+import Data.List.NonEmpty (NonEmpty, fromList, intersperse) import Data.Maybe (fromMaybe, catMaybes) import Data.Semigroup ((<>)) import Data.String (IsString(fromString))@@ -121,15 +120,14 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Builder as Builder-import Data.ByteString.Lazy (toStrict) import qualified Data.CaseInsensitive as CI import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time.Clock (UTCTime)-import Data.Time.Format (defaultTimeLocale, parseTimeOrError)+import Data.Time.Format (defaultTimeLocale, parseTimeM)  import Data.RFC5322-import Data.RFC5322.Internal+import Data.RFC5322.Internal hiding (takeWhile1) import Data.MIME.Error import Data.MIME.Charset import Data.MIME.EncodedWord@@ -138,13 +136,13 @@  {- $create -Create an inline, plain text message and render it:+Create an __inline, plain text message__ and __render__ it:  @ λ> import Data.MIME λ> msg = 'createTextPlainMessage' "Hello, world!" λ> s = 'renderMessage' msg-λ> B.putStrLn s+λ> L.putStrLn s MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Disposition: inline@@ -153,13 +151,13 @@ Hello, world! @ -Set the @From@ and @To@ headers:+Set the __@From@__ and __@To@__ headers:  @ λ> alice = Mailbox Nothing (AddrSpec "alice" (DomainDotAtom ("example" :| ["com"]))) λ> bob = Mailbox Nothing (AddrSpec "bob" (DomainDotAtom ("example" :| ["net"])))-λ> msgFromAliceToBob = set 'headerFrom' [alice] . set 'headerTo' [Single bob] $ msg-λ> B.putStrLn (renderMessage msgFromAliceToBob)+λ> msgFromAliceToBob = set ('headerFrom' 'defaultCharsets' [alice] . set ('headerTo' defaultCharsets) [Single bob] $ msg+λ> L.putStrLn (renderMessage msgFromAliceToBob) MIME-Version: 1.0 From: alice@example.com To: bob@example.net@@ -171,18 +169,41 @@ @  The 'headerFrom', 'headerTo', 'headerCC' and 'headerBCC' lenses are the most-convenient interface for reading and setting the sender and recipient-addresses.  Note that you would usually not manually construct email addresses+convenient interface for reading and setting the __sender and recipient addresses__.+Note that you would usually not manually construct email addresses manually as was done above.  Instead you would usually read it from another email or configuration, or parse addresses from user input. -Create a multipart message with attachment:+The __@Subject@__ header is set via 'headerSubject'.  __Other single-valued headers__+can be set via 'headerText'.  @+λ> :{+| L.putStrLn . renderMessage $+|   set ('headerText' defaultCharsets "Comments") (Just "와")+|   . set ('headerSubject' defaultCharsets) (Just "Hi from Alice")+|   $ msgFromAliceToBob+| :}++MIME-Version: 1.0+Comments: =?utf-8?B?7JmA?=+Subject: Hi from Alice+From: alice@example.com+To: bob@example.net+Content-Transfer-Encoding: 7bit+Content-Disposition: inline+Content-Type: text/plain; charset=us-ascii++Hello, world!+@++Create a __multipart message with attachment__:++@ λ> attachment = 'createAttachment' "application/json" (Just "data.json") "{\"foo\":42}" λ> msg2 = 'createMultipartMixedMessage' "boundary" [msg, attachment] λ> s2 = 'renderMessage' msg2-λ> B.putStrLn s2+λ> L.putStrLn s2 MIME-Version: 1.0 Content-Type: multipart/mixed; boundary=boundary @@ -202,11 +223,14 @@  @ +__NOTE:__ if you only need to write a serialised 'Message' to an +IO handle, 'buildMessage' is more efficient than 'renderMessage'.+ -}  {- $parse -Most often you will parse a message like this:+Most often you will __parse a message__ like this:  @ λ> parsedMessage = 'parse' ('message' 'mime') s2@@ -227,7 +251,7 @@ {- $inspect  Parsing an email is nice, but your normally want to get at the-content inside.  One of the most important tasks is finding entities+content inside.  One of the most important tasks is __finding entities__ of interest, e.g. attachments, plain text or HTML bodies.  The 'entities' optic is a fold over all /leaf/ entities in the message. That is, all the non-multipart bodies.  You can use 'filtered' to@@ -256,7 +280,9 @@ @  For __attachments__ you are normally interested in the binary data-and possibly the filename (if specified).  In the following example we retrieve all attachments, and their filenames, as a list of tuples (although there is only one in the message).  Note that+and possibly the filename (if specified).  In the following example+we retrieve all attachments, and their filenames, as a list of+tuples (although there is only one in the message).  Note that  Get the (optional) filenames and (decoded) body of all attachments, as a list of tuples.  The 'attachments' optic selects non-multipart@@ -298,7 +324,7 @@  @ λ> msg3 = createTextPlainMessage "ɥǝןןo ʍoɹןp"-λ> B.putStrLn $ renderMessage msg3+λ> L.putStrLn $ renderMessage msg3 MIME-Version: 1.0 Content-Transfer-Encoding: base64 Content-Disposition: inline@@ -724,9 +750,9 @@ -- This parser accepts non-MIME messages, and -- treats them as a single part. ---mime :: Headers -> Parser MIME+mime :: Headers -> BodyHandler MIME mime h-  | nullOf (header "MIME-Version") h = Part <$> takeByteString+  | nullOf (header "MIME-Version") h = RequiredBody (Part <$> takeByteString)   | otherwise = mime' takeByteString h  type instance MessageContext MIME = EncStateWire@@ -737,8 +763,8 @@   -- multipart, we pass it on to the 'multipart' parser.  If this   -- part is not multipart, we just do the take.   -> Headers-  -> Parser MIME-mime' takeTillEnd h = case view contentType h of+  -> BodyHandler MIME+mime' takeTillEnd h = RequiredBody $ case view contentType h of   ct | view ctType ct == "multipart" ->     case preview (rawParameter "boundary") ct of       Nothing -> FailedParse MultipartBoundaryNotSpecified <$> takeTillEnd@@ -778,33 +804,24 @@       | C8.last s == '\r' = B.init s       | otherwise = s --- | Serialise a given `MIMEMessage` into a ByteString.------ Sets the @MIME-Version: 1.0@ header (on the top-level message only).--- No other headers are set.----renderMessage :: MIMEMessage -> B.ByteString-renderMessage = toStrict . Builder.toLazyByteString . buildMessage---- | Serialise a given `MIMEMessage` using a `Builder`------ Sets the @MIME-Version: 1.0@ header (on the top-level message only).--- No other headers are set.+-- | Sets the @MIME-Version: 1.0@ header. ---buildMessage :: MIMEMessage -> Builder.Builder-buildMessage = go . set (headers . at "MIME-Version") (Just "1.0")-  where-  go (Message h z) = buildFields h <> case z of-    Part partbody -> "\r\n" <> Builder.byteString partbody-    Encapsulated msg -> "\r\n" <> buildMessage msg+instance RenderMessage MIME where+  tweakHeaders = set (headers . at "MIME-Version") (Just "1.0")+  buildBody h z = Just $ case z of+    Part partbody -> Builder.byteString partbody+    Encapsulated msg -> buildMessage msg     Multipart xs ->       let b = firstOf (contentType . mimeBoundary) h-          boundary = maybe mempty (\b' -> "\r\n--" <> Builder.byteString b') b-          ents = foldMap (\part -> boundary <> "\r\n" <> go part) xs-      in ents <> boundary <> "--\r\n"-    FailedParse _ bs -> "\r\n" <> Builder.byteString bs+          boundary = maybe mempty (\b' -> "--" <> Builder.byteString b') b+      in+        boundary <> "\r\n"+        <> fold (intersperse ("\r\n" <> boundary <> "\r\n") (fmap buildMessage xs))+        <> "\r\n" <> boundary <> "--\r\n"+    FailedParse _ bs -> Builder.byteString bs  + -- | Map a single-occurrence header to a list value. -- On read, absent header is mapped to empty list. -- On write, empty list results in absent header.@@ -818,26 +835,45 @@ headerSingleToList f g k =   headers . at k . iso (maybe [] f) (\l -> if null l then Nothing else Just (g l)) -headerFrom :: HasHeaders a => Lens' a [Mailbox]-headerFrom = headerSingleToList (either (const []) id . parseOnly mailboxList) renderMailboxes "From"+headerFrom :: HasHeaders a => CharsetLookup -> Lens' a [Mailbox]+headerFrom charsets = headerSingleToList+  (either (const []) id . parseOnly (mailboxList charsets))+  renderMailboxes+  "From" -headerAddressList :: (HasHeaders a) => CI B.ByteString -> Lens' a [Address]-headerAddressList = headerSingleToList (either (const []) id . parseOnly addressList) renderAddresses+headerAddressList :: (HasHeaders a) => CI B.ByteString -> CharsetLookup -> Lens' a [Address]+headerAddressList k charsets = headerSingleToList+  (either (const []) id . parseOnly (addressList charsets))+  renderAddresses+  k -headerTo, headerCC, headerBCC :: (HasHeaders a) => Lens' a [Address]+headerTo, headerCC, headerBCC :: (HasHeaders a) => CharsetLookup -> Lens' a [Address] headerTo = headerAddressList "To" headerCC = headerAddressList "Cc" headerBCC = headerAddressList "Bcc" -headerDate :: HasHeaders a => Lens' a UTCTime-headerDate = headers . lens getter setter+headerDate :: HasHeaders a => Lens' a (Maybe UTCTime)+headerDate = headers . at "Date" . iso (parseDate =<<) (fmap renderRFC5422Date)   where-    -- TODO for parseTimeOrError. See #16-    getter =-        parseTimeOrError True defaultTimeLocale rfc5422DateTimeFormat-        . C8.unpack . view (header "date")-    setter hdrs x = set (header "date") (renderRFC5422Date x) hdrs+    parseDate =+        parseTimeM True defaultTimeLocale rfc5422DateTimeFormatLax . C8.unpack +-- | Single-valued header with @Text@ value via encoded-words.+-- The conversion to/from Text is total (encoded-words that failed to be+-- decoded are passed through unchanged).  Therefore @Nothing@ means that+-- the header was not present.+--+-- This function is suitable for the @Subject@ header.+--+headerText :: (HasHeaders a) => CharsetLookup -> CI B.ByteString -> Lens' a (Maybe T.Text)+headerText charsets k =+  headers . at k . iso (fmap (decodeEncodedWords charsets)) (fmap encodeEncodedWords)++-- | Subject header.  See 'headerText' for details of conversion to @Text@.+headerSubject :: (HasHeaders a) => CharsetLookup -> Lens' a (Maybe T.Text)+headerSubject charsets = headerText charsets "Subject"++ -- | Returns a space delimited `B.ByteString` with values from identification -- fields from the parents message `Headers`. Rules to gather the values are in -- accordance to RFC5322 - 3.6.4 as follows sorted by priority (first has@@ -861,21 +897,6 @@ -- | Create a mixed `MIMEMessage` with an inline text/plain part and multiple -- `attachments` ----- Additional headers can be set (e.g. @Cc@) by using `At` and `Ixed`, for--- example:------ @--- λ> set (at "subject") (Just "Hey there") $ Headers []--- Headers [("subject", "Hey there")]--- @------ You can also use the `Mailbox` instances:------ @--- λ> let address = Mailbox (Just "roman") (AddrSpec "roman" (DomainLiteral "192.168.1.1"))--- λ> set (at "cc") (Just $ renderMailbox address) $ Headers []--- Headers [("cc", "\\"roman\\" <roman@192.168.1.1>")]--- @ createMultipartMixedMessage     :: B.ByteString -- ^ Boundary     -> NonEmpty MIMEMessage -- ^ parts

@@ -9,7 +9,8 @@ -} module Data.MIME.Base64   (-    contentTransferEncodeBase64+    b+  , contentTransferEncodeBase64   , contentTransferEncodingBase64   ) where @@ -61,4 +62,9 @@ contentTransferEncodingBase64 :: ContentTransferEncoding contentTransferEncodingBase64 = prism'   contentTransferEncodeBase64+  (either (const Nothing) Just . contentTransferDecodeBase64)++b :: ContentTransferEncoding+b = prism'+  B64.encode   (either (const Nothing) Just . contentTransferDecodeBase64)

@@ -9,25 +9,37 @@ -} module Data.MIME.EncodedWord   (-    decodeEncodedWords+    decodeEncodedWord+  , decodeEncodedWords+  , EncodedWord+  , encodedWord+  , buildEncodedWord+  , encodeEncodedWords+  , chooseEncodedWordEncoding   ) where  import Control.Applicative ((<|>), liftA2, optional)-import Data.Bifunctor (first) import Data.Semigroup ((<>))+import Data.Maybe (fromMaybe)+import Data.Monoid (Sum(Sum), Any(Any)) -import Control.Lens (to, clonePrism, review, view)+import Control.Lens (to, clonePrism, review, view, foldMapOf) import Data.Attoparsec.ByteString import Data.Attoparsec.ByteString.Char8 (char8)+import Data.ByteString.Lens (bytes) import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Builder as Builder import qualified Data.CaseInsensitive as CI import qualified Data.Text as T import qualified Data.Text.Encoding as T  import Data.MIME.Charset+import Data.MIME.Error (EncodingError) import Data.MIME.TransferEncoding+import Data.MIME.Base64 import Data.MIME.QuotedPrintable-import Data.RFC5322.Internal+import Data.RFC5322.Internal (ci, takeTillString)  data EncodedWord = EncodedWord   { _encodedWordCharset :: CI.CI B.ByteString@@ -87,15 +99,20 @@     encodedText = takeWhile1 (\c -> (c >= 33 && c < 63) || (c > 63 && c <= 127))  serialiseEncodedWord :: EncodedWord -> B.ByteString-serialiseEncodedWord (EncodedWord charset lang enc s) =-  "=?" <> CI.original charset-  <> maybe "" (\l -> "*" <> CI.original l) lang-  <> "?" <> CI.original enc <> -  "?" <> s <> "?="+serialiseEncodedWord = L.toStrict . Builder.toLazyByteString . buildEncodedWord +buildEncodedWord :: EncodedWord -> Builder.Builder+buildEncodedWord (EncodedWord charset lang enc s) =+  "=?" <> Builder.byteString (CI.original charset)+  <> maybe "" (\l -> "*" <> Builder.byteString (CI.original l)) lang+  <> "?" <> Builder.byteString (CI.original enc)+  <> "?" <> Builder.byteString s <> "?="++ transferEncodeEncodedWord :: TransferDecodedEncodedWord -> EncodedWord transferEncodeEncodedWord (TransferDecodedEncodedWord charset lang s) =-  EncodedWord charset lang "Q" (review (clonePrism q) s)+  let (enc, p) = fromMaybe ("Q", q) (chooseEncodedWordEncoding s)+  in EncodedWord charset lang enc (review (clonePrism p) s)  -- | RFC 2047 and RFC 2231 define the /encoded-words/ mechanism for -- embedding non-ASCII data in headers.  This function locates@@ -126,21 +143,45 @@ -- decodeEncodedWords :: CharsetLookup -> B.ByteString -> T.Text decodeEncodedWords charsets s =-  either (const $ decodeLenient s) merge $ fmap (g . f) <$> parseOnly tokens s+  either (const (decodeLenient s)) (foldMap conv) (parseOnly tokens s)   where-    -- parse the ByteString into a series of tokens-    -- of either raw ASCII text, or EncodedWords+    tokens :: Parser [Either B.ByteString EncodedWord]     tokens = liftA2 (:) (Left <$> takeTillString "=?") more           <|> ((:[]) . Left <$> takeByteString)     more = liftA2 (:) (Right <$> encodedWord <|> pure (Left "=?")) tokens+    conv = either decodeLenient (decodeEncodedWord charsets) -    f (Left t) = Left t-    f (Right w) = first-      (const $ serialiseEncodedWord w :: TransferEncodingError -> B.ByteString)-      (view transferDecoded w)-    g (Left t) = Left t-    g (Right w) = first-      (const $ serialiseEncodedWord $ transferEncodeEncodedWord w :: CharsetError -> B.ByteString)-      (view (charsetDecoded charsets) w)+-- | Decode an 'EncodedWord'.  If transfer or charset decoding fails,+-- returns the serialised encoded word.+decodeEncodedWord :: CharsetLookup -> EncodedWord -> T.Text+decodeEncodedWord charsets w =+  either+    (decodeLenient . const (serialiseEncodedWord w) :: EncodingError -> T.Text)+    id+    (view transferDecoded w >>= view (charsetDecoded charsets)) -    merge = foldMap (either decodeLenient id)+-- | This function encodes necessary parts of some text+--+-- Currently turns the whole text into a single encoded word, if necessary.+encodeEncodedWords :: T.Text -> B.ByteString+encodeEncodedWords t = maybe utf8 (const ew) (chooseEncodedWordEncoding utf8)+  where+    ew = B.intercalate " " . fmap encOrNot . B.split 32 $ utf8+    encOrNot s = maybe s (g s) (chooseEncodedWordEncoding s)+    g s (enc, p) = serialiseEncodedWord $+      EncodedWord "utf-8" Nothing enc (review (clonePrism p) s)+    utf8 = T.encodeUtf8 t++chooseEncodedWordEncoding :: B.ByteString -> Maybe (TransferEncodingName, TransferEncoding)+chooseEncodedWordEncoding s+  | not doEnc = Nothing+  | nQP < nB64 = Just ("Q", q)+  | otherwise = Just ("B", b)+  where+    -- https://tools.ietf.org/html/rfc5322#section-3.5 'text'+    needEnc c = c > 127 || c == 0+    qpBytes c+      | encodingRequiredNonEOL Q c = 3+      | otherwise = 1+    (Any doEnc, Sum nQP) = foldMapOf bytes (\c -> (Any (needEnc c), Sum (qpBytes c))) s+    nB64 = ((B.length s + 2) `div` 3) * 4

@@ -37,12 +37,11 @@ -- | Whether it is required to encode a character -- (where that character does not precede EOL). encodingRequiredNonEOL :: QuotedPrintableMode -> Word8 -> Bool-encodingRequiredNonEOL mode c = not (-  (c >= 33 && c <= 60)-  || (c >= 62 && c <= 126)-  || c == 9-  || c == 32-  ) || (mode == Q && c == 95 {- underscore -})+encodingRequiredNonEOL mode c =+  (c < 32 {- ' ' -} && c /= 9 {- \t -})+  || c == 61 {- = -}+  || c >= 127+  || mode == Q && (c == 95 {- _ -} || c == 9 {- \t -} || c == 63 {- ? -})   -- | Whether it is required to encode a character@@ -85,6 +84,7 @@       -- is there a crlf at this location?       crlf :: Ptr Word8 -> IO Bool       crlf ptr+        | mode == Q = pure False  -- always encode CRLF in 'Q' mode         | ptr `plusPtr` 1 >= slimit = pure False         | otherwise = do           c1 <- peek ptr@@ -106,6 +106,11 @@       mapChar 32 {- ' ' -} | mode == Q = 95 {- _ -}       mapChar c = c +      -- Do not wrap lines in Q mode.  This is not correct,+      -- but encoded-word wrapping needs separate encoded-words+      -- including the leading =?... and trailing ?=+      wrapLimit = if mode == Q then maxBound else 76+       fill col !dp !sp         | sp >= slimit = pure $ dp `minusPtr` dptr         | otherwise = do@@ -122,7 +127,7 @@                     || encodingRequiredNonEOL mode c                   bytesNeeded = bool 1 3 encodingRequired                   c' = mapChar c-                case (col + bytesNeeded >= 76, encodingRequired) of+                case (col + bytesNeeded >= wrapLimit, encodingRequired) of                   (False, False) ->                     poke' dp c'                     *> fill (col + bytesNeeded) (dp `plusPtr` bytesNeeded) (sp `plusPtr` 1)

@@ -103,7 +103,7 @@   , ("quoted-printable", contentTransferEncodingQuotedPrintable)   , ("base64", contentTransferEncodingBase64)   , ("q", q)-  , ("b", contentTransferEncodingBase64)+  , ("b", b)   ]  -- | Inspect the data and choose a transfer encoding to use: @7bit@

@@ -1,8 +1,13 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}  {- |@@ -19,7 +24,7 @@ that can inspect the headers to determine how to parse the body.  @-'message' :: ('Headers' -> Parser a) -> Parser (Message ctx a)+'message' :: ('Headers' -> 'BodyHandler' a) -> Parser (Message ctx a) @  The 'Message' type is parameterised over the body type, and a@@ -61,6 +66,7 @@     Message(..)   , message   , MessageContext+  , BodyHandler(..)   , body   , EqMessage(..) @@ -91,11 +97,16 @@   -- * Helpers   , field   , rfc5422DateTimeFormat+  , rfc5422DateTimeFormatLax    -- * Serialisation+  , buildMessage+  , renderMessage+  , RenderMessage(..)   , renderRFC5422Date   , buildFields   , buildField+  , renderAddressSpec   , renderMailbox   , renderMailboxes   , renderAddress@@ -117,17 +128,26 @@ import Data.Attoparsec.ByteString.Char8 (char8) import qualified Data.Attoparsec.ByteString.Lazy as AL import qualified Data.ByteString as B-import Data.ByteString.Lazy (toStrict)+import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Builder.Prim as Prim import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time.Clock (UTCTime) import Data.Time.Format (defaultTimeLocale, formatTime)  import Data.RFC5322.Internal+  ( CI, ci, original+  , (<<>>), foldMany, foldMany1Sep+  , fromChar, isAtext, isQtext, isVchar, isWsp+  , optionalCFWS, word, wsp, vchar, optionalFWS, crlf+  , domainLiteral, dotAtom, localPart, quotedString+  ) import Data.RFC5322.Address.Types-import Data.MIME.Charset (decodeLenient)+import Data.MIME.Charset+import Data.MIME.EncodedWord (encodedWord, decodeEncodedWord, buildEncodedWord)+import Data.MIME.TransferEncoding (transferEncode)  type Header = (CI B.ByteString, B.ByteString) newtype Headers = Headers [Header]@@ -193,9 +213,15 @@ -- possibly in response to body data, or vice-versa, when -- comparing messages. --+-- The default implementation compares headers and body using (==).+-- class EqMessage a where   eqMessage :: Message s a -> Message s a -> Bool +  default eqMessage :: (Eq a) => Message s a -> Message s a -> Bool+  eqMessage (Message h1 b1) (Message h2 b2) = h1 == h2 && b1 == b2++ instance EqMessage a => Eq (Message s a) where   (==) = eqMessage @@ -219,54 +245,113 @@ rfc5422DateTimeFormat :: String rfc5422DateTimeFormat = "%a, %d %b %Y %T %z" +rfc5422DateTimeFormatLax :: String+rfc5422DateTimeFormatLax = "%a, %-d %b %Y %-H:%-M:%-S %z"+ renderRFC5422Date :: UTCTime -> B.ByteString renderRFC5422Date = Char8.pack . formatTime defaultTimeLocale rfc5422DateTimeFormat  -- §3.4 Address Specification buildMailbox :: Mailbox -> Builder.Builder buildMailbox (Mailbox n a) =-  maybe a' (\n' -> renderDisplayName n' <> "<" <> a' <> ">") n+  maybe a' (\n' -> buildPhrase n' <> " <" <> a' <> ">") n   where-    a' = renderAddressSpec a+    a' = buildAddressSpec a -renderDisplayName :: T.Text -> Builder.Builder-renderDisplayName x =-    mconcat-        [ "\""-        , Builder.byteString (T.encodeUtf8 x)-        , "\" "]+-- Encode a phrase.+--+-- * Empty string is special case; must be in quotes+-- * If valid as an atom, use as-is (ideally, but we don't do this yet)+-- * If it can be in a quoted-string, do so.+-- * Otherwise make it an encoded-word+--+buildPhrase :: T.Text -> Builder.Builder+buildPhrase "" = "\"\""+buildPhrase s =+  case enc s of+    PhraseAtom -> T.encodeUtf8Builder s+    PhraseQuotedString _ -> "\"" <> T.encodeUtf8BuilderEscaped escPrim s <> "\""+    PhraseEncodedWord -> buildEncodedWord . transferEncode . charsetEncode $ s+  where+    enc = T.foldr (\c z -> encChar c <> z) mempty+    encChar c+      | isAtext c = PhraseAtom+      | isQtext c = PhraseQuotedString 0+      | isVchar c || c == ' ' = PhraseQuotedString 1+      | otherwise = PhraseEncodedWord +    -- FIXME: this probably doesn't handle consecutive SPACE properly+    -- due to FWS:+    --+    --    quoted-string   =   [CFWS]+    --                        DQUOTE *([FWS] qcontent) [FWS] DQUOTE+    --                        [CFWS]+    --+    -- Do not be surprised if the roundtrip property fails+    --+    escPrim = Prim.condB (\c -> isQtext c || c == 32)+      (Prim.liftFixedToBounded Prim.word8)+      (Prim.liftFixedToBounded $ (fromChar '\\',) Prim.>$< Prim.word8 Prim.>*< Prim.word8)++-- | Data type used to compute escaping requirement of a Text 'phrase'+-- 'PhraseQuotedString' records the number of additional characters+-- needed for escapes (backslash).  It does not include the surrounding+-- DQUOTE characters.+--+data PhraseEscapeRequirement = PhraseAtom | PhraseQuotedString Int | PhraseEncodedWord++instance Semigroup PhraseEscapeRequirement where+  PhraseEncodedWord <> _ = PhraseEncodedWord+  PhraseAtom <> a = a+  PhraseQuotedString n <> PhraseQuotedString m = PhraseQuotedString (n + m)+  a <> PhraseAtom = a+  _ <> PhraseEncodedWord = PhraseEncodedWord++instance Monoid PhraseEscapeRequirement where+  mempty = PhraseAtom+++ renderMailboxes :: [Mailbox] -> B.ByteString-renderMailboxes = toStrict . Builder.toLazyByteString . buildMailboxes+renderMailboxes = L.toStrict . Builder.toLazyByteString . buildMailboxes  buildMailboxes :: [Mailbox] -> Builder.Builder buildMailboxes = fold . Data.List.intersperse ", " . fmap buildMailbox  renderMailbox :: Mailbox -> B.ByteString-renderMailbox = toStrict . Builder.toLazyByteString . buildMailbox+renderMailbox = L.toStrict . Builder.toLazyByteString . buildMailbox -mailbox :: Parser Mailbox-mailbox = Mailbox <$> optional displayName <*> angleAddr-          <|> Mailbox Nothing <$> addressSpec+mailbox :: CharsetLookup -> Parser Mailbox+mailbox charsets =+  Mailbox <$> optional (displayName charsets) <*> angleAddr+  <|> Mailbox Nothing <$> addressSpec -displayName :: Parser T.Text-displayName = decodeLenient <$> phrase+phrase :: CharsetLookup -> Parser T.Text+phrase charsets = foldMany1Sep " " $+  fmap (decodeEncodedWord charsets) ("=?" *> encodedWord)+  <|> fmap decodeLenient word +displayName :: CharsetLookup -> Parser T.Text+displayName = phrase+ angleAddr :: Parser AddrSpec angleAddr = optionalCFWS *>   char8 '<' *> addressSpec <* char8 '>'   <* optionalCFWS -renderAddressSpec :: AddrSpec -> Builder.Builder-renderAddressSpec (AddrSpec lp (DomainDotAtom b))+buildAddressSpec :: AddrSpec -> Builder.Builder+buildAddressSpec (AddrSpec lp (DomainDotAtom b))   | " " `B.isInfixOf` lp = "\"" <> buildLP <> "\"" <> rest   | otherwise = buildLP <> rest   where     buildLP = Builder.byteString lp     rest = "@" <> foldMap Builder.byteString (Data.List.NonEmpty.intersperse "." b)-renderAddressSpec (AddrSpec lp (DomainLiteral b)) =+buildAddressSpec (AddrSpec lp (DomainLiteral b)) =   foldMap Builder.byteString [lp, "@", b] +renderAddressSpec :: AddrSpec -> B.ByteString+renderAddressSpec = L.toStrict . Builder.toLazyByteString . buildAddressSpec+ addressSpec :: Parser AddrSpec addressSpec = AddrSpec <$> localPart <*> (char8 '@' *> domain) @@ -278,8 +363,8 @@ domain = (DomainDotAtom <$> dotAtom)          <|> (DomainLiteral <$> domainLiteral) -mailboxList :: Parser [Mailbox]-mailboxList = mailbox `sepBy` char8 ','+mailboxList :: CharsetLookup -> Parser [Mailbox]+mailboxList charsets = mailbox charsets `sepBy` char8 ','  renderAddresses :: [Address] -> B.ByteString renderAddresses xs = B.intercalate ", " $ renderAddress <$> xs@@ -288,25 +373,37 @@ renderAddress (Single m) = renderMailbox m renderAddress (Group name xs) = T.encodeUtf8 name <> ":" <> renderMailboxes xs <> ";" -addressList :: Parser [Address]-addressList = address `sepBy` char8 ','+addressList :: CharsetLookup -> Parser [Address]+addressList charsets = address charsets `sepBy` char8 ',' -group :: Parser Address-group = Group <$> displayName <* char8 ':' <*> mailboxList <* char8 ';' <* optionalCFWS+group :: CharsetLookup -> Parser Address+group charsets =+  Group <$> (displayName charsets) <* char8 ':'+        <*> mailboxList charsets <* char8 ';' <* optionalCFWS -address :: Parser Address-address = group <|> Single <$> mailbox+address :: CharsetLookup -> Parser Address+address charsets =+  group charsets <|> Single <$> mailbox charsets  -- §3.5.  Overall Message Syntax  --- | Parse a message, given function from headers to body parser------ This parser does not handle the legitimate but obscure case--- of a message with no body (empty body is fine, though).+-- | Specify how to handle a message body, including the possibility+-- of optional bodies and no body (which is distinct from empty body).+data BodyHandler a+  = RequiredBody (Parser a)+  | OptionalBody (Parser a, a)+  -- ^ If body is present run parser, otherwise use constant value+  | NoBody a++-- | Parse a message.  The function argument receives the headers and+-- yields a handler for the message body. ---message :: (Headers -> Parser a) -> Parser (Message (MessageContext a) a)-message f = fields >>= \hdrs -> Message hdrs <$> (crlf *> f hdrs)+message :: (Headers -> BodyHandler a) -> Parser (Message (MessageContext a) a)+message f = fields >>= \hdrs -> Message hdrs <$> case f hdrs of+  RequiredBody b -> crlf *> b+  OptionalBody (b, a) -> optional crlf >>= maybe (pure a) (const b)+  NoBody b -> pure b  type family MessageContext a @@ -314,6 +411,32 @@ fields :: Parser Headers fields = Headers <$> many field +-- | Define how to render an RFC 5322 message with given payload type.+--+class RenderMessage a where+  -- | Build the body.  If there should be no body (as distinct from+  -- /empty body/) return Nothing+  buildBody :: Headers -> a -> Maybe Builder.Builder++  -- | Allows tweaking the headers before rendering.  Default+  -- implementation is a no-op.+  tweakHeaders :: Headers -> Headers+  tweakHeaders = id++-- | Construct a 'Builder.Builder' for the message.  This allows efficient+-- streaming to IO handles.+--+buildMessage :: forall ctx a. (RenderMessage a) => Message ctx a -> Builder.Builder+buildMessage (Message h b) =+  buildFields (tweakHeaders @a h)+  <> maybe mempty ("\r\n" <>) (buildBody h b)++-- | Render a message to a lazy 'L.ByteString'.  (You will probably not+-- need a strict @ByteString@ and it is inefficient for most use cases.)+--+renderMessage :: (RenderMessage a) => Message ctx a -> L.ByteString+renderMessage = Builder.toLazyByteString . buildMessage+ -- Header serialisation buildFields :: Headers -> Builder.Builder buildFields = foldMapOf (hdriso . traversed) buildField@@ -345,7 +468,7 @@ foldUnstructured :: Int -> B.ByteString -> B.ByteString foldUnstructured i b =     let xs = chunk (i + 2) (Char8.words b) [] []-    in B.intercalate "\r\n " xs+    in B.intercalate "\r\n " (filter (not . B.null) xs)  chunk :: Int -> [B.ByteString] -> [B.ByteString] -> [B.ByteString] -> [B.ByteString] chunk _ [] xs result = result <> [Char8.unwords xs]

@@ -15,6 +15,7 @@   , renderMailboxes   , renderAddress   , renderAddresses+  , renderAddressSpec   ) where  import Control.Applicative ((<|>), optional)@@ -48,7 +49,7 @@ buildMailbox (Mailbox n a) =   maybe a' (\n' -> "\"" <> Builder.fromText n' <> "\" " <> "<" <> a' <> ">") n   where-    a' = renderAddressSpec a+    a' = buildAddressSpec a  renderAddresses :: [Address] -> T.Text renderAddresses xs = T.intercalate ", " $ renderAddress <$> xs@@ -57,21 +58,30 @@ renderAddress (Single m) = renderMailbox m renderAddress (Group name xs) = name <> ":" <> renderMailboxes xs <> ";" -renderAddressSpec :: AddrSpec -> Builder.Builder-renderAddressSpec (AddrSpec lp (DomainDotAtom b))+buildAddressSpec :: AddrSpec -> Builder.Builder+buildAddressSpec (AddrSpec lp (DomainDotAtom b))   | " " `B.isInfixOf` lp = "\"" <> buildLP <> "\"" <> rest   | otherwise = buildLP <> rest   where     buildLP = Builder.fromText $ decodeLenient lp     rest = "@" <> foldMap Builder.fromText (decodeLenient <$> Data.List.NonEmpty.intersperse "." b)-renderAddressSpec (AddrSpec lp (DomainLiteral b)) =+buildAddressSpec (AddrSpec lp (DomainLiteral b)) =   foldMap Builder.fromText [decodeLenient lp, "@", decodeLenient b] +renderAddressSpec :: AddrSpec -> T.Text+renderAddressSpec = LT.toStrict . Builder.toLazyText . buildAddressSpec + -- §3.4 Address Specification mailbox :: Parser Mailbox mailbox = Mailbox <$> optional displayName <*> angleAddr           <|> Mailbox Nothing <$> addressSpec++-- | Version of 'phrase' that does not process encoded-word+-- (we are parsing Text so will assume that the input does not+-- contain encoded words.  TODO this is probably wrong :)+phrase :: Parser T.Text+phrase = foldMany1Sep (singleton ' ') word  displayName :: Parser T.Text displayName = phrase

@@ -19,11 +19,14 @@   , optionalCFWS   , crlf   , vchar+  , word   , quotedString-  , phrase   , dotAtom   , localPart   , domainLiteral+  , IsChar(..)+  , CharParsing(..)+  , SM    -- ** Helpers for building parsers   , isAtext@@ -35,6 +38,7 @@   , (<<>>)   , foldMany   , foldMany1+  , foldMany1Sep    -- * General parsers and combinators   , skipTill@@ -202,9 +206,6 @@  word :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s word = atom <|> quotedString--phrase :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s-phrase = foldMany1Sep (singleton ' ') word  dotAtomText :: (Alternative (f s), CharParsing f s a) => (f s) (NonEmpty s) dotAtomText = fromList <$> (takeWhile1 isAtext `A.sepBy1` char '.')

@@ -0,0 +1,22 @@+module EncodedWord where++import qualified Data.Text as T+import qualified Data.Text.Encoding as T++import Data.MIME.Charset+import Data.MIME.EncodedWord++import Test.Tasty+import Test.Tasty.Hedgehog+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++properties :: TestTree+properties = localOption (HedgehogTestLimit (Just 1000)) $+  testProperty "encodeEncodedWords roundtrip" prop_roundtrip++prop_roundtrip :: Property+prop_roundtrip = property $ do+  t <- forAll $ Gen.text (Range.linear 0 1000) Gen.unicode+  decodeEncodedWords defaultCharsets (encodeEncodedWords t) === t

@@ -34,7 +34,7 @@         "renders simple mail"         diffCommand         "tests/golden/textplain7bit.golden"-        (pure $ LB.fromStrict $ renderMessage textPlain7bit)+        (pure $ renderMessage textPlain7bit)  diffCommand :: FilePath -> FilePath -> [String] diffCommand ref new =@@ -50,7 +50,7 @@         "renders simple, multi-part mail"         diffCommand         "tests/golden/multipart.golden"-        (pure $ LB.fromStrict $ renderMessage multiPartMail)+        (pure $ renderMessage multiPartMail)  exampleMailsParseSuccessfully :: TestTree exampleMailsParseSuccessfully =

@@ -54,16 +54,16 @@     bob = Mailbox Nothing (AddrSpec "bob" (DomainDotAtom ("example" :| ["com"])))     carol = Mailbox Nothing (AddrSpec "carol" (DomainDotAtom ("example" :| ["com"])))     msg = createTextPlainMessage "hi"-    fromAlice = set headerFrom [alice] msg-    fromAliceToBob = set headerTo [Single bob] fromAlice-    fromAliceToCarolAndBob = over headerTo (Single carol :) fromAliceToBob+    fromAlice = set (headerFrom defaultCharsets) [alice] msg+    fromAliceToBob = set (headerTo defaultCharsets) [Single bob] fromAlice+    fromAliceToCarolAndBob = over (headerTo defaultCharsets) (Single carol :) fromAliceToBob   in-    [ testCase "From empty" $ view headerFrom msg @?= []-    , testCase "To empty" $ view headerTo msg @?= []-    , testCase "set From alice" $ view headerFrom fromAlice @?= [alice]-    , testCase "set To bob" $ view headerTo fromAliceToBob @?= [Single bob]-    , testCase "add To carol" $ view headerTo fromAliceToCarolAndBob @?= [Single carol, Single bob]-    , testCase "removing header" $ has (header "From") (set headerFrom [] fromAlice) @?= False+    [ testCase "From empty" $ view (headerFrom defaultCharsets) msg @?= []+    , testCase "To empty" $ view (headerTo defaultCharsets) msg @?= []+    , testCase "set From alice" $ view (headerFrom defaultCharsets) fromAlice @?= [alice]+    , testCase "set To bob" $ view (headerTo defaultCharsets) fromAliceToBob @?= [Single bob]+    , testCase "add To carol" $ view (headerTo defaultCharsets) fromAliceToCarolAndBob @?= [Single carol, Single bob]+    , testCase "removing header" $ has (header "From") (set (headerFrom defaultCharsets) [] fromAlice) @?= False     ]  rendersFieldsSuccessfully :: TestTree@@ -79,7 +79,7 @@           , "Subject: Re: Simple Subject\r\n")         , ( "continuous line"           , ("Subject", "ThisisalongcontiniousLineWithoutAnyWhiteSpaceandNowSomeGarbageASDFASDFASDFASDF")-          , "Subject: \r\n ThisisalongcontiniousLineWithoutAnyWhiteSpaceandNowSomeGarbageASDFASDFASDFASDF\r\n")+          , "Subject: ThisisalongcontiniousLineWithoutAnyWhiteSpaceandNowSomeGarbageASDFASDFASDFASDF\r\n")         , ( "folding"           , ( "Received"             , "from adsl-33-138-215-182-129-129.test.example ([XX.XX.XXX.XXX]) by this.is.another.hostname.example with esmtp (Exim 4.24) id 1Akwaj-00035l-NT for me@test.example; Sun, 25 2004 21:35:09 -0500")@@ -180,7 +180,7 @@ parsesTextMailboxesSuccessfully =     testGroup "parsing mailboxes (text)" $     (\(desc,f,input) ->-          testCase desc $ f (parseOnly mailbox input)) <$>+          testCase desc $ f (parseOnly (mailbox defaultCharsets) input)) <$>     mailboxFixtures  addresses :: IsString s => [(String, Either String Address -> Assertion, s)]@@ -203,7 +203,7 @@ parsesAddressesSuccessfully :: TestTree parsesAddressesSuccessfully =     testGroup "parsing addresses" $-    (\(desc,f,input) -> testCase desc $ f (parseOnly address input))+    (\(desc,f,input) -> testCase desc $ f (parseOnly (address defaultCharsets) input))     <$> addresses  parsesTextAddressesSuccessfully :: TestTree

@@ -26,6 +26,7 @@ import Data.Either (isLeft) import Data.List.NonEmpty (fromList) import Data.String (fromString)+import Data.Time.Clock (UTCTime)  import Control.Lens import qualified Data.ByteString as B@@ -43,6 +44,7 @@ unittests = testGroup "MIME tests"   [ testContentDisposition   , testParse+  , testOptics   , testParameterValueOverloadedStrings   , testContentTypeOverloadedStrings   ]@@ -191,3 +193,31 @@       (isLeft <$> (try . evaluate $ fromString "foo/; baz=quux" :: IO (Either ErrorCall ContentType)))       >>= assertBool "bogus string throws error"   ]++testOptics :: TestTree+testOptics = testGroup "optics tests"+  [ testCase "headerDate get valid date" $+      testHeaderDateGet+      "Thu, 4 May 2017 03:08:43 +0000"+      (Just $ read "2017-05-04 03:08:43 UTC")+  , testCase "headerDate get invalid date" $+      testHeaderDateGet+      "Thu, 4 NOTMAY 2017 03:08:43 +0000"+      Nothing+  , testCase "headerDate set" $+      testHeaderDateSet (Just $ read "2017-05-04 03:08:43 UTC")+  , testCase "headerDate unset" $ testHeaderDateSet Nothing+  ]++testHeaderDateGet :: B.ByteString -> Maybe UTCTime -> Assertion+testHeaderDateGet headerStr time =+  view headerDate msg @?= time+  where+    Right msg = parse (message mime) msgStr+    msgStr = "Date: " <> headerStr <> "\n\nbody\n" :: B.ByteString++testHeaderDateSet :: Maybe UTCTime -> Assertion+testHeaderDateSet time =+  view headerDate msg @?= time+  where+    msg = set headerDate time $ createTextPlainMessage "body"

@@ -14,77 +14,111 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>. +{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+ {- | -Generators and instances for messages and parts thereof.+Generators and properties for messages and parts thereof.  -} module Message where -import Data.Char (isAscii, isPrint)-import Data.List.NonEmpty (fromList)+import Data.Char (isPrint)+import Data.Foldable (fold)+import Data.List.NonEmpty (NonEmpty, intersperse) -import qualified Data.ByteString.Char8 as B+import Control.Lens (set, view)+import qualified Data.ByteString as B import qualified Data.Text as T  import Test.Tasty-import Test.Tasty.QuickCheck+import Test.Tasty.Hedgehog+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range  import Data.MIME+import Data.RFC5322.Internal (isAtext)  tests :: TestTree tests = testGroup "message tests"   [ testProperty "message round trip" prop_messageRoundTrip+  , localOption (HedgehogTestLimit (Just 10000)) $+      testProperty "message round trip with From header" prop_messageFromRoundTrip   ] -genPrintAsciiChar :: Gen Char-genPrintAsciiChar = arbitraryPrintableChar `suchThat` isAscii--genAscii1 :: Gen T.Text-genAscii1 = T.pack <$> listOf1 genPrintAsciiChar--genText1 :: Gen T.Text-genText1 = T.pack <$> listOf1 arbitraryPrintableChar+printableAsciiChar, printableUnicodeChar, unicodeCharAsciiBias :: Gen Char+printableAsciiChar = Gen.filter isPrint Gen.ascii+printableUnicodeChar = Gen.filter isPrint Gen.unicode -genTextPlain :: Gen MIMEMessage-genTextPlain = createTextPlainMessage <$> oneof [genAscii1, genText1]+-- | We need a generator that has ascii bias to make sequences+-- like "\r\n" more likely.+unicodeCharAsciiBias = Gen.frequency [(3, Gen.ascii), (1, Gen.unicode)] --- Generate a 50 character multipart boundary.  These MUST be unique--- for all (nested) multipart messages.  Hopefully 50 chars is--- enough to have a low-enough probability of collision.-genBoundary :: Gen B.ByteString-genBoundary = B.pack <$> vectorOf 50 genPrintAsciiChar+asciiText1, unicodeText1 :: Gen T.Text+asciiText1 = Gen.text (Range.linear 1 100) printableAsciiChar+unicodeText1 = Gen.text (Range.linear 1 100) printableUnicodeChar --- Multipart message with at least one part.-genMultipart1 = depths >>= go+genTextPlain, genMultipart, genMessage :: Gen MIMEMessage+genTextPlain = createTextPlainMessage <$> Gen.choice [asciiText1, unicodeText1]+genMultipart = depths >>= go   where-  go :: Int -> Gen MIMEMessage+  -- Generate a 50 character multipart boundary.  These MUST be unique+  -- for all (nested) multipart messages.  Assume negligible probability+  -- of collision.+  genBoundary = Gen.utf8 (Range.singleton 50) printableAsciiChar+   go 0 = genTextPlain-  go n = do-    len <- choose (1, 10) -- up to 10 subparts, minimum of 1-    createMultipartMixedMessage+  go n = createMultipartMixedMessage       <$> genBoundary-      <*> ( fromList <$>+      <*> ( Gen.nonEmpty (Range.linear 1 10) $             -- 75% plain, 25% nested multipart-            vectorOf len (maybeAp encapsulate 5 $ frequency [(3, genTextPlain), (1, go (n - 1))])+            maybeAp encapsulate 5 $ Gen.frequency [(3, genTextPlain), (1, go (n - 1))]           )    -- max depth of 4-  depths = frequency+  depths :: Gen Int+  depths = Gen.frequency     [ (1, pure 1)     , (5, pure 2)     , (3, pure 3)     , (1, pure 4)     ] --- | Apply the function to the generated value with probability 1-in-/n/.-maybeAp :: (a -> a) -> Int -> Gen a -> Gen a-maybeAp f n g = frequency [(n - 1, g), (1, f <$> g)]--genMessage :: Gen MIMEMessage-genMessage = oneof [ genTextPlain, genMultipart1, encapsulate <$> genMessage ]+  -- Apply the function to the generated value with probability 1-in-/n/.+  maybeAp f n g = Gen.frequency [(n - 1, g), (1, f <$> g)] +genMessage = Gen.choice [ genTextPlain, genMultipart, encapsulate <$> genMessage ]  prop_messageRoundTrip :: Property-prop_messageRoundTrip = forAll genMessage $ \msg ->-  parse (message mime) (renderMessage msg) == Right msg+prop_messageRoundTrip = property $ do+  msg <- forAll genMessage+  parse (message mime) (renderMessage msg) === Right msg++prop_messageFromRoundTrip :: Property+prop_messageFromRoundTrip = property $ do+  from <- forAll genMailbox+  let+    l = headerFrom defaultCharsets+    msg = set l [from] (createTextPlainMessage "Hello")+  (view l <$> parse (message mime) (renderMessage msg)) === Right [from]++genDomain :: Gen Domain+genDomain = DomainDotAtom <$> genDotAtom -- TODO domain literal++genDotAtom :: Gen (NonEmpty B.ByteString)+genDotAtom = Gen.nonEmpty (Range.linear 1 5) (Gen.utf8 (Range.linear 1 20) (Gen.filter isAtext Gen.ascii))++genLocalPart :: Gen B.ByteString+genLocalPart = fold . intersperse "." <$> genDotAtom++genAddrSpec :: Gen AddrSpec+genAddrSpec = AddrSpec <$> genLocalPart <*> genDomain++genMailbox :: Gen Mailbox+genMailbox =+  Mailbox+  <$> Gen.maybe (Gen.text (Range.linear 0 100) unicodeCharAsciiBias)+  <*> genAddrSpec

@@ -14,15 +14,21 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>. +{-# LANGUAGE OverloadedStrings #-}+ module Parser where +import Data.Either (isLeft)+ import Data.Attoparsec.ByteString.Lazy as AL import Data.ByteString as B import Data.ByteString.Lazy as L import Test.QuickCheck.Instances () import Test.Tasty+import Test.Tasty.HUnit import Test.Tasty.QuickCheck +import Data.RFC5322 import Data.RFC5322.Internal (takeTillString)  tests :: TestTree@@ -36,4 +42,40 @@           case AL.parse (AL.string h *> takeTillString c) s' of             AL.Done r' l' -> r' == L.fromStrict r && l' == l             _ -> False+  , testBodyParsing   ]+++data Antibody = Antibody+  deriving (Eq, Show)++instance EqMessage Antibody++data MaybeBody = NotPresent | Present B.ByteString+  deriving (Eq, Show)++instance EqMessage MaybeBody+++testBodyParsing :: TestTree+testBodyParsing = testGroup "BodyHandler tests"+  [ testCase "empty body" $+      parseOnly (message (const $ NoBody Antibody) <* endOfInput) msg+      @?= Right (Message hdrs Antibody)+  , testCase "optional body (present, parses)" $+      parseOnly (message opt <* endOfInput) (msg <> "\r\nyeah")+      @?= Right (Message hdrs (Present "yeah"))+  , testCase "optional body (present, no parse)" $+      isLeft (parseOnly (message opt <* endOfInput) (msg <> "\r\nnah"))+      @?= True+  , testCase "optional body (present, empty)" $+      isLeft (parseOnly (message opt <* endOfInput) (msg <> "\r\n"))+      @?= True+  , testCase "optional body (absent)" $+      parseOnly (message opt <* endOfInput) msg+      @?= Right (Message hdrs NotPresent)+  ]+  where+    msg = "From: alice@example.net\r\n"+    hdrs = Headers [("From", "alice@example.net")]+    opt _ = OptionalBody (Present <$> AL.string "yeah", NotPresent)

@@ -1,7 +1,7 @@ import Test.Tasty-import Test.Tasty.QuickCheck  import ContentTransferEncodings as CTE+import EncodedWord import MIME import Headers import Generator@@ -12,6 +12,7 @@ main =   defaultMain $ testGroup "Tests"     [ CTE.properties+    , EncodedWord.properties     , Headers.unittests     , Generator.properties     , MIME.unittests

@@ -6,12 +6,14 @@ Content-Type: multipart/mixed; boundary=asdf
 
 --asdf
+MIME-Version: 1.0
 Content-Transfer-Encoding: 7bit
 Content-Disposition: inline
 Content-Type: text/plain; charset=us-ascii
 
 This is a simple mail.
 --asdf
+MIME-Version: 1.0
 Content-Transfer-Encoding: 7bit
 Content-Disposition: attachment; filename=foo.bin
 Content-Type: application/octet-stream