purebred-email 0.2.0.0 → 0.3.0.0

raw patch · 19 files changed

+651/−248 lines, 19 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• README.rst +1/−1
• purebred-email.cabal +9/−8
• src/Data/MIME.hs +309/−168
• src/Data/MIME/Charset.hs +15/−8
• src/Data/MIME/EncodedWord.hs +1/−0
• src/Data/MIME/Parameter.hs +20/−2
• src/Data/MIME/QuotedPrintable.hs +3/−0
• src/Data/MIME/TransferEncoding.hs +37/−9
• src/Data/MIME/Types.hs +0/−2
• src/Data/RFC5322.hs +47/−12
• src/Data/RFC5322/Internal.hs +9/−10
• tests/Generator.hs +3/−1
• tests/Headers.hs +10/−10
• tests/MIME.hs +45/−5
• tests/Message.hs +90/−0
• tests/Parser.hs +39/−0
• tests/Test.hs +4/−0
• tests/golden/multipart.golden +6/−9
• tests/golden/textplain7bit.golden +3/−3

@@ -1,1 +1,1 @@-Email handling library.  Groks RFC 5322 and MIME.+Email handling library.  RFC 5322, MIME and more.

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                purebred-email-version:             0.2.0.0+version:             0.3.0.0 synopsis:            types and parser for email messages (including MIME) description:   The purebred email library.  RFC 5322, MIME, etc.@@ -10,16 +10,15 @@   Things that are currently implemented:   .   - RFC 5322 message parsing and serialisation-  - MIME multipart parsing (RFC 2046)+  - MIME multipart parsing (RFC 2046) and serialisation   - MIME message header extensions for non-ASCII text (RFC 2047)   - MIME parameter value and encoded word extensions (RFC 2231)   - Content-Disposition header field (RFC 2183)+  - Message encapsulation (forward/bounce)   .   Things that are not yet implemented / need improvement:   .-  - Support for more charsets   - Improve handling of dates-  - Sensible heuristics for choosing a content transfer encoding   - Probably lots of other things  license:             AGPL-3@@ -35,7 +34,7 @@   tests/golden/*.golden cabal-version:       >=1.10 tested-with:-  GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.1+  GHC==8.4.4, GHC==8.6.5, GHC==8.8.1  homepage:            https://github.com/purebred-mua/purebred-email bug-reports:         https://github.com/purebred-mua/purebred-email/issues@@ -52,6 +51,7 @@     Data.RFC5322     , Data.RFC5322.Address.Text     , Data.RFC5322.Address.Types+    , Data.RFC5322.Internal     , Data.MIME     , Data.MIME.Error     , Data.MIME.Charset@@ -62,11 +62,10 @@     , Data.MIME.Base64     , Data.MIME.QuotedPrintable   other-modules:-    Data.RFC5322.Internal-    , Data.MIME.Internal+    Data.MIME.Internal   -- other-extensions:       build-depends:-    base >= 4.8 && < 5+    base >= 4.11 && < 5     , attoparsec >= 0.13 && < 0.14     , base64-bytestring >= 1 && < 2     , bytestring >= 0.10 && < 0.11@@ -93,6 +92,8 @@     , Headers     , MIME     , Generator+    , Parser+    , Message   build-depends:     base     , bytestring

@@ -9,17 +9,28 @@  {- | -MIME messages (RFC 2045, RFC 2046 and friends).+MIME messages (RFC 2045, RFC 2046, RFC 2183 and friends). +This module extends "Data.RFC5322" with types for handling MIME+messages.  It provides the 'mime' parsing helper function for+use with 'message'.+ -} module Data.MIME   (-  -- * Overview-  -- $overview+  -- * Overview / HOWTO+  -- ** Creating and serialising mail+  -- $create -  -- * Examples / HOWTO-  -- $examples+  -- ** Parsing mail+  -- $parse +  -- ** Inspecting messages+  -- $inspect++  -- ** Unicode support+  -- $unicode+   -- * API    -- ** MIME data type@@ -38,6 +49,7 @@   , attachments   , isAttachment   , transferDecoded+  , transferDecoded'   , charsetDecoded    -- ** Header processing@@ -73,16 +85,19 @@   , buildMessage    -- ** Mail creation+  -- *** Common use cases+  , createTextPlainMessage+  , createAttachment+  , createAttachmentFromFile+  , createMultipartMixedMessage+  , encapsulate+  -- *** Setting headers   , headerFrom   , headerTo   , headerCC   , headerBCC   , headerDate   , replyHeaderReferences-  , createAttachmentFromFile-  , createAttachment-  , createTextPlainMessage-  , createMultipartMixedMessage    -- * Re-exports   , CharsetLookup@@ -93,9 +108,10 @@   ) where  import Control.Applicative-import Control.Monad (void)+import Data.List.NonEmpty (NonEmpty, fromList) import Data.Maybe (fromMaybe, catMaybes) import Data.Semigroup ((<>))+import Data.String (IsString(fromString)) import GHC.Generics (Generic)  import Control.DeepSeq (NFData)@@ -119,102 +135,186 @@ import Data.MIME.EncodedWord import Data.MIME.Parameter import Data.MIME.TransferEncoding-import Data.MIME.Types (Encoding(..)) -{- $overview+{- $create -This module extends 'Data.RFC5322' with types for handling MIME-messages.  It provides the 'mime' parsing helper function for-use with 'message'.+Create an inline, plain text message and render it:  @-'mime' :: Headers -> Parser MIME-message mime :: Parser (Message ctx MIME)+λ> import Data.MIME+λ> msg = 'createTextPlainMessage' "Hello, world!"+λ> s = 'renderMessage' msg+λ> B.putStrLn s+MIME-Version: 1.0+Content-Transfer-Encoding: 7bit+Content-Type: text/plain; charset=us-ascii+Content-Disposition: inline++Hello, world! @ -The 'Message' data type has a phantom type parameter for context.-In this module we use it to track whether the body has-/content transfer encoding/ or /charset encoding/ applied.  Type-aliases are provided for convenince.+__TODO__ show how to set From,To,Cc,etc. -@-data 'Message' ctx a = Message Headers a-data 'EncStateWire'-data 'EncStateByte'+Create a multipart message with attachment: -type 'MIMEMessage' = Message EncStateWire MIME-type 'WireEntity' = Message EncStateWire B.ByteString-type 'ByteEntity' = Message EncStateByte B.ByteString-type 'TextEntity' = Message () T.Text @+λ> attachment = 'createAttachment' "application/json" (Just "data.json") "{\"foo\":42}"+λ> msg2 = 'createMultipartMixedMessage' "boundary" [msg, attachment]+λ> s2 = 'renderMessage' msg2+λ> B.putStrLn s2+MIME-Version: 1.0+Content-Type: multipart/mixed; boundary=boundary -Folds are provided over all leaf /entities/, and entities that are-identified as attachments:+--boundary+Content-Transfer-Encoding: 7bit+Content-Disposition: inline+Content-Type: text/plain; charset=us-ascii -@-'entities' :: Fold MIMEMessage WireEntity-'attachments' :: Fold MIMEMessage WireEntity-@+Hello, world!+--boundary+Content-Transfer-Encoding: 7bit+Content-Disposition: attachment; filename=data.json+Content-Type: application/json -Content transfer decoding is performed using the 'transferDecoded'-optic.  This will convert /Quoted-Printable/ or /Base64/ encoded-entities into their decoded form.+{"foo":42}+--boundary--  @-'transferDecoded' :: Getter WireEntity (Either 'TransferEncodingError' ByteEntity)-transferDecoded :: Getter WireEntity (Either 'EncodingError' ByteEntity)-transferDecoded :: (HasTransferEncoding a, AsTransferEncodingError e) => Getter a (Either e (TransferDecoded a))-@ -Charset decoding is performed using the 'charsetDecoded' optic:+-} +{- $parse++Most often you will parse a message like this:+ @-'charsetDecoded' :: Getter ByteEntity (Either 'CharsetError' TextEntity)-charsetDecoded :: Getter ByteEntity (Either 'EncodingError' TextEntity)-charsetDecoded :: (HasCharset a, AsCharsetError e) => Getter a (Either e (Decoded a))+λ> parsedMessage = 'parse' ('message' 'mime') s2+λ> :t parsedMessage+parsedMessage :: Either String 'MIMEMessage'+λ> parsedMessage == Right msg2+True @ +The 'message' function builds a parser for a message.  It is+abstracted over the body type; the argument is a function that can+inspect headers and return a parser for the body.  If you are+parsing MIME messages (or plain RFC 5322 messages), the 'mime'+function is the right one to use.+ -} -{- $examples+{- $inspect -__Parse__ a MIME message:+Parsing an email is nice, but your normally want to get at the+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+refine the query. +For example, let's say you want to find the first @text/plain@+entity in a message.  Define a predicate with the help of the+'matchContentType' function:+ @-'parse' (message mime) :: ByteString -> Either String MIMEMessage+λ> isTextPlain = 'matchContentType' "text" (Just "plain") . view 'contentType'+λ> :t isTextPlain+isTextPlain :: HasHeaders s => s -> Bool+λ> isTextPlain msg+True+λ> isTextPlain msg2+False @ -Find the first entity with the @text/plain@ __content type__:+Now we can use the predicate to construct a fold and retrieve the+body.  If there is no matching entity the result would be @Nothing@.  @-getTextPlain :: 'MIMEMessage' -> Maybe 'WireEntity'-getTextPlain = firstOf ('entities' . filtered f)-  where-  f = 'matchContentType' "text" (Just "plain") . view ('headers' . 'contentType')+λ> firstOf ('entities' . filtered isTextPlain . 'body') msg2+Just "Hello, world!" @ -Perform __content transfer decoding__ /and/ __charset__ decoding-while preserving decode errors:+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 +Get the (optional) filenames and (decoded) body of all attachments,+as a list of tuples.  The 'attachments' optic selects non-multipart+entities with @Content-Disposition: attachment@.  The 'attachments'+fold targets all entities with @Content-Disposition: attachment@.+The 'transferDecoded'' optic undoes the @Content-Transfer-Encoding@+of the entity.+ @-view 'transferDecoded' >=> view 'charsetDecoded' :: WireEntity -> Either EncodingError TextEntity+λ> getFilename = preview ('contentDisposition' . _Just . 'filename' 'defaultCharsets')+λ> getBody = preview ('transferDecoded'' . _Right . 'body')+λ> getAttachment = liftA2 (,) getFilename getBody+λ> toListOf ('attachments' . to getAttachment) msg2+[(Just "data.json",Just "{\"foo\":42}")] @ -Get all __attachments__ (transfer decoded) and their __filenames__ (if specified):+Finally, note that the 'filename' optic takes an argument: it is a+function for looking up a character set.  Supporting every possible+character encoding is a bit tricky so we let the user supply a map+of supported charsets, and provide 'defaultCharsets' which supports+ASCII, UTF-8 and ISO-8859-1.  @-getAttachments :: 'MIMEMessage' -> [(Either 'TransferEncodingError' B.ByteString, Maybe T.Text)]-getAttachments = toListOf ('attachments' . to (liftA2 (,) content name)-  where-  content = view 'transferDecodedBytes'-  name = preview ('headers' . 'contentDisposition' . 'filename')+λ> :t 'filename'+filename+  :: ('HasParameters' a, Applicative f) =>+     'CharsetLookup' -> (T.Text -> f T.Text) -> a -> f a+λ> :t 'defaultCharsets'+defaultCharsets :: CharsetLookup+λ> :i CharsetLookup+type CharsetLookup = CI Char8.ByteString -> Maybe Data.MIME.Charset.Charset @ -Create an inline, plain text message and render it:+-} +{- $unicode++In Australia we say "Hello world" upside down:+ @-renderMessage $ createTextPlainMessage "This is a test body"+λ> msg3 = createTextPlainMessage "ɥǝןןo ʍoɹןp"+λ> B.putStrLn $ renderMessage msg3+MIME-Version: 1.0+Content-Transfer-Encoding: base64+Content-Disposition: inline+Content-Type: text/plain; charset=utf-8++yaXHndef159vIMqNb8m5159w+ @++Charset set and transfer encoding are handled automatically.  If the+message only includes characters representable in ASCII, the charset+will be @us-ascii@, otherwise @utf-8@.++To read the message as @Text@ you must perform transfer decoding and+charset decoding.  The 'transferDecoded' optic performs transfer+decoding, as does its sibling 'transferDecoded'' which is+monomorphic in the error type.  Similarly, 'charsetText' and+'charsetText'' perform text decoding according to the character set.++If you don't mind throwing away decoding errors, the simplest way to+get the text of a message is:++@+λ> Just ent = firstOf ('entities' . filtered isTextPlain) msg3+λ> :t ent+ent :: 'WireEntity'+λ> text = preview ('transferDecoded'' . _Right . 'charsetText'' 'defaultCharsets' . _Right) ent+λ> :t text+text :: Maybe T.Text+λ> traverse_ T.putStrLn text+ɥǝןןo ʍoɹןp+@++As mentioned earlier, functions that perform text decoding take a+'CharsetLookup' parameter, and we provide 'defaultCharsets' for+convenience.+ -}  @@ -238,28 +338,40 @@ -- data MIME   = Part B.ByteString-  | Multipart [MIMEMessage]+  | Encapsulated MIMEMessage+  | Multipart (NonEmpty MIMEMessage)+  | FailedParse MIMEParseError B.ByteString   deriving (Eq, Show) --- | Get all leaf entities from the MIME message+-- | Ignores the presence/absense of @MIME-Version@ header+instance EqMessage MIME where+  Message h1 b1 `eqMessage` Message h2 b2 =+    stripVer h1 == stripVer h2 && b1 == b2+    where+    stripVer = set (headers . at "MIME-Version") Nothing++-- | Get all leaf entities from the MIME message.+-- Entities that failed to parse are skipped. -- entities :: Traversal' MIMEMessage WireEntity entities f (Message h a) = case a of   Part b ->     (\(Message h' b') -> Message h' (Part b')) <$> f (Message h b)+  Encapsulated msg -> Message h . Encapsulated <$> entities f msg   Multipart bs ->     Message h . Multipart <$> sequenceA (entities f <$> bs)+  FailedParse _ _ -> pure (Message h a)  -- | Leaf entities with @Content-Disposition: attachment@ attachments :: Traversal' MIMEMessage WireEntity-attachments = entities . filtered (notNullOf l) where-  l = headers . contentDisposition . dispositionType . filtered (== Attachment)+attachments = entities . filtered isAttachment  -- | MIMEMessage content disposition is an 'Attachment'-isAttachment :: MIMEMessage -> Bool-isAttachment = has (headers . contentDisposition . dispositionType . filtered (== Attachment))+isAttachment :: HasHeaders a => a -> Bool+isAttachment = has (contentDisposition . _Just . dispositionType . filtered (== Attachment)) -contentTransferEncoding :: Getter Headers TransferEncodingName+contentTransferEncoding+  :: (Profunctor p, Contravariant f) => Optic' p f Headers TransferEncodingName contentTransferEncoding = to $   fromMaybe "7bit"   . preview (header "content-transfer-encoding" . caseInsensitive)@@ -270,9 +382,14 @@   transferEncodedData = body   transferDecoded = to $ \a -> (\t -> set body t a) <$> view transferDecodedBytes a -printContentTransferEncoding :: Encoding -> B.ByteString-printContentTransferEncoding Base64 = "base64"-printContentTransferEncoding None = "7bit"+  transferEncode (Message h s) =+    let+      (cteName, cte) = chooseTransferEncoding s+      s' = review (clonePrism cte) s+      cteName' = CI.original cteName+      h' = set (headers . at "Content-Transfer-Encoding") (Just cteName') h+    in+      Message h' s'  caseInsensitive :: CI.FoldCase s => Iso' s (CI s) caseInsensitive = iso CI.mk CI.original@@ -284,9 +401,12 @@ -- Example: -- -- @--- ContentType "text" "plain" [("charset", "utf-8")]+-- ContentType "text" "plain" (Parameters [("charset", "utf-8")]) -- @ --+-- You can also use @-XOverloadedStrings@ but be aware the conversion+-- is non-total (throws an error if it cannot parse the string).+-- data ContentType = ContentType (CI B.ByteString) (CI B.ByteString) Parameters   deriving (Show, Generic, NFData) @@ -298,6 +418,14 @@ instance Eq ContentType where   ContentType a b c == ContentType a' b' c' = a == a' && b == b' && c == c' +-- | __NON-TOTAL__ parses the Content-Type (including parameters)+-- and throws an error if the parse fails+--+instance IsString ContentType where+  fromString = either err id . parseOnly parseContentType . C8.pack+    where+    err msg = error $ "failed to parse Content-Type: " <> msg+ -- | Match content type.  If @Nothing@ is given for subtype, any -- subtype is accepted. --@@ -394,7 +522,7 @@     let       b = T.encodeUtf8 a       charset = if B.all (< 0x80) b then "us-ascii" else "utf-8"-    in Message (set (contentType . rawParameter "charset") charset h) b+    in Message (set (contentType . parameter "charset") (Just charset) h) b  -- | RFC 6657 provides for different media types having different -- ways to determine the charset.  This data type defines how a@@ -405,10 +533,10 @@   -- ^ Charset should be declared within payload (e.g. xml, rtf).   --   The given function reads it from the payload.   | InParameter (Maybe CharsetName)-  -- ^ Charset should be declared in the 'charset' parameter,+  -- ^ Charset should be declared in the @charset@ parameter,   --   with optional fallback to the given default.   | InBandOrParameter (B.ByteString -> Maybe CharsetName) (Maybe CharsetName)-  -- ^ Check in-band first, fall back to 'charset' parameter,+  -- ^ Check in-band first, fall back to @charset@ parameter,   --   and further optionally fall back to a default.  -- | Charset sources for text/* media types.  IANA registry:@@ -439,18 +567,18 @@  -- | @text/plain@ contentTypeTextPlain :: ContentType-contentTypeTextPlain = ContentType "text" "plain" (Parameters [])+contentTypeTextPlain = ContentType "text" "plain" mempty  -- | @application/octet-stream@ contentTypeApplicationOctetStream :: ContentType contentTypeApplicationOctetStream =-  ContentType "application" "octet-stream" (Parameters [])+  ContentType "application" "octet-stream" mempty  -- | @multipart/mixed; boundary=asdf@ contentTypeMultipartMixed :: B.ByteString -> ContentType contentTypeMultipartMixed boundary =-  over parameterList (("boundary", boundary):)-  $ ContentType "multipart" "mixed" (Parameters [])+  set (parameter "boundary") (Just (ParameterValue Nothing Nothing boundary))+  $ ContentType "multipart" "mixed" mempty  -- | Lens to the content-type header.  Probably not a lawful lens. --@@ -467,8 +595,8 @@ -- otherwise it is added.  Unrecognised Content-Transfer-Encoding -- is ignored when setting. ---contentType :: Lens' Headers ContentType-contentType = lens sa sbt where+contentType :: HasHeaders a => Lens' a ContentType+contentType = headers . lens sa sbt where   sa s = case view cte s of     Nothing -> contentTypeApplicationOctetStream     Just _ ->@@ -524,17 +652,19 @@   where     typStr = case typ of Inline -> "inline" ; Attachment -> "attachment" --- | Get Content-Disposition header.+-- | Access @Content-Disposition@ header.+-- -- Unrecognised disposition types are coerced to @Attachment@ -- in accordance with RFC 2183 §2.8 which states:--- /Unrecognized disposition types should be treated as/ attachment.+-- /Unrecognized disposition types should be treated as attachment/. ----- The fold may be empty, e.g. if the header is absent or unparseable.+-- This optic does not distinguish between missing header or malformed+-- value. ---contentDisposition :: Traversal' Headers ContentDisposition-contentDisposition =-  header "content-disposition"-  . parsePrint parseContentDisposition printContentDisposition+contentDisposition :: HasHeaders a => Lens' a (Maybe ContentDisposition)+contentDisposition = headers . at "Content-Disposition" . dimap+  (>>= either (const Nothing) Just . Data.RFC5322.parse parseContentDisposition)+  (fmap . fmap $ printContentDisposition)  -- | Traverse the value of the filename parameter (if present). --@@ -570,7 +700,7 @@ -- -- Preambles and epilogues are discarded. ----- This parser accepts non-MIME messages, and unconditionally+-- This parser accepts non-MIME messages, and -- treats them as a single part. -- mime :: Headers -> Parser MIME@@ -578,6 +708,8 @@   | nullOf (header "MIME-Version") h = Part <$> takeByteString   | otherwise = mime' takeByteString h +type instance MessageContext MIME = EncStateWire+ mime'   :: Parser B.ByteString   -- ^ Parser FOR A TAKE to the part delimiter.  If this part is@@ -588,21 +720,34 @@ mime' takeTillEnd h = case view contentType h of   ct | view ctType ct == "multipart" ->     case preview (rawParameter "boundary") ct of-      Nothing -> part-      Just boundary -> Multipart <$> multipart takeTillEnd boundary+      Nothing -> FailedParse MultipartBoundaryNotSpecified <$> takeTillEnd+      Just boundary ->+        (Multipart <$> multipart takeTillEnd boundary)+        <|> (FailedParse MultipartParseFail <$> takeTillEnd)+     | matchContentType "message" (Just "rfc822") ct ->+        (Encapsulated <$> message (mime' takeTillEnd))+        <|> (FailedParse EncapsulatedMessageParseFail <$> takeTillEnd)   _ -> part   where     part = Part <$> takeTillEnd +data MIMEParseError+  = MultipartBoundaryNotSpecified+  | MultipartParseFail+  | EncapsulatedMessageParseFail+  deriving (Eq, Show)+ -- | Parse a multipart MIME message.  Preambles and epilogues are -- discarded. -- multipart   :: Parser B.ByteString  -- ^ parser to the end of the part   -> B.ByteString         -- ^ boundary, sans leading "--"-  -> Parser [MIMEMessage]+  -> Parser (NonEmpty MIMEMessage) multipart takeTillEnd boundary =-  multipartBody+  skipTillString dashBoundary *> crlf -- FIXME transport-padding+  *> fmap fromList (part `sepBy1` crlf)+  <* string "--" <* takeTillEnd   where     delimiter = "\n--" <> boundary     dashBoundary = B.tail delimiter@@ -612,59 +757,46 @@       | C8.last s == '\r' = B.init s       | otherwise = s -    multipartBody =-      skipTillString dashBoundary *> crlf -- FIXME transport-padding-      *> part `sepBy` crlf-      <* string "--" <* takeTillEnd---- | Serialise a given `MIMEMessage` into a ByteString. The message is--- serialised as is. No additional headers are set.+-- | 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.+-- buildMessage :: MIMEMessage -> Builder.Builder-buildMessage (Message h (Part partbody)) =-    buildFields h <> "\r\n" <> Builder.byteString partbody-buildMessage (Message h (Multipart xs)) =-    let b = firstOf (contentType . mimeBoundary) h-        boundary = maybe mempty (\b' -> "\r\n--" <> Builder.byteString b') b-        ents = foldMap (\part -> boundary <> "\r\n" <> buildMessage part) xs-    in buildFields h <> ents <> boundary <> "--\r\n"---mimeHeader :: (CI B.ByteString, B.ByteString)-mimeHeader = (CI.mk "MIME-Version", "1.0")---- | creates a new `MIMEMessage` and transfer encodes the given content with the--- given Encoding-createMessage-    :: ContentType-    -> ContentDisposition-    -> Encoding-    -> B.ByteString -- ^ content-    -> MIMEMessage-createMessage ct cd encoding content =-  let m = Message (Headers [mimeHeader]) (Part $ transferEncodeData encoding content)-  in m-  & set (headers . at "Content-Type") (Just (printContentType ct))-  . set (headers . at "Content-Disposition") (Just (printContentDisposition cd))-  . set (headers . at "Content-Transfer-Encoding") (Just (printContentTransferEncoding encoding))+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+    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 -headerFrom :: Lens' Headers [Mailbox]-headerFrom = lens getter setter+headerFrom :: HasHeaders a => Lens' a [Mailbox]+headerFrom = headers . lens getter setter   where     getter = either (pure []) id . parseOnly mailboxList . view (header "from")     setter = flip $ set (header "from") . renderMailboxes -headerTo :: Lens' Headers [Address]-headerTo = lens (headerGetter "to") (headerSetter "to")+headerTo :: HasHeaders a => Lens' a [Address]+headerTo = headers . lens (headerGetter "to") (headerSetter "to") -headerCC :: Lens' Headers [Address]-headerCC = lens (headerGetter "cc") (headerSetter "cc")+headerCC :: HasHeaders a => Lens' a [Address]+headerCC = headers . lens (headerGetter "cc") (headerSetter "cc") -headerBCC :: Lens' Headers [Address]-headerBCC = lens (headerGetter "bcc") (headerSetter "bcc")+headerBCC :: HasHeaders a => Lens' a [Address]+headerBCC = headers . lens (headerGetter "bcc") (headerSetter "bcc")  headerSetter :: CI B.ByteString -> Headers -> [Address] -> Headers headerSetter fieldname = flip $ set (header fieldname) . renderAddresses@@ -673,8 +805,8 @@ headerGetter fieldname =     either (pure []) id . parseOnly addressList . view (header fieldname) -headerDate :: Lens' Headers UTCTime-headerDate = lens getter setter+headerDate :: HasHeaders a => Lens' a UTCTime+headerDate = headers . lens getter setter   where     -- TODO for parseTimeOrError. See #16     getter =@@ -686,13 +818,15 @@ -- 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 -- precedence):--- * Values from 'References' and `Message-ID` (if any)--- * Values from 'In-Reply-To' and 'Message-ID' (if any)--- * Value from 'Message-ID' (in case it's the first reply to a parent mail)--- * otherwise Nothing is returned indicating that the replying mail should not have a 'References' field. ---replyHeaderReferences :: Getter Headers (Maybe C8.ByteString)-replyHeaderReferences = to $ \hdrs ->+-- * Values from @References@ and @Message-ID@ (if any)+-- * Values from @In-Reply-To@ and @Message-ID@ (if any)+-- * Value from @Message-ID@ (in case it's the first reply to a parent mail)+-- * Otherwise @Nothing@ is returned indicating that the replying mail should+--   not have a @References@ field.+--+replyHeaderReferences :: HasHeaders a => Getter a (Maybe C8.ByteString)+replyHeaderReferences = (.) headers $ to $ \hdrs ->   let xs = catMaybes         [preview (header "references") hdrs          <|> preview (header "in-reply-to") hdrs@@ -703,7 +837,7 @@ -- | 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+-- Additional headers can be set (e.g. @Cc@) by using `At` and `Ixed`, for -- example: -- -- @@@ -720,27 +854,23 @@ -- @ createMultipartMixedMessage     :: B.ByteString -- ^ Boundary-    -> [MIMEMessage] -- ^ attachments+    -> NonEmpty MIMEMessage -- ^ parts     -> MIMEMessage createMultipartMixedMessage b attachments' =-    let hdrs =-            set-                (at "Content-Type")-                (Just $ printContentType (contentTypeMultipartMixed b)) $-            Headers [mimeHeader]+    let hdrs = mempty &+                set contentType (contentTypeMultipartMixed b)     in Message hdrs (Multipart attachments')  -- | Create an inline, text/plain, utf-8 encoded message ---createTextPlainMessage-    :: T.Text -- ^ message body-    -> MIMEMessage-createTextPlainMessage =-    createMessage-        contentTypeTextPlain-        (ContentDisposition Inline $ Parameters [(CI.mk "charset", "utf-8")])-        None-    . T.encodeUtf8+createTextPlainMessage :: T.Text -> MIMEMessage+createTextPlainMessage s = fmap Part $ transferEncode $ charsetEncode msg+  where+  msg = Message hdrs s :: TextEntity+  cd = ContentDisposition Inline mempty+  hdrs = mempty+          & set contentType contentTypeTextPlain+          & set contentDisposition (Just cd)  -- | Create an attachment from a given file path. -- Note: The filename content disposition is set to the given `FilePath`. For@@ -749,12 +879,23 @@ createAttachmentFromFile :: ContentType -> FilePath -> IO MIMEMessage createAttachmentFromFile ct fp = createAttachment ct (Just fp) <$> B.readFile fp --- | Create an attachment from the given file contents. Optionally set the given+-- | Create an attachment from the given file contents. Optionally set the -- filename parameter to the given file path. -- createAttachment :: ContentType -> Maybe FilePath -> B.ByteString -> MIMEMessage-createAttachment ct fp =-    set-        (headers . contentDisposition . filenameParameter)-        (newParameter . T.pack <$> fp) .-    createMessage ct (ContentDisposition Attachment $ Parameters []) Base64+createAttachment ct fp s = Part <$> transferEncode msg+  where+  msg = Message hdrs s+  cd = ContentDisposition Attachment cdParams+  cdParams = mempty & set filenameParameter (newParameter <$> fp)+  hdrs = mempty+          & set contentType ct+          & set contentDisposition (Just cd)++-- | Encapsulate a message as a @message/rfc822@ message.+-- You can use this in creating /forwarded/ or /bounce/ messages.+--+encapsulate :: MIMEMessage -> MIMEMessage+encapsulate = Message hdrs . Encapsulated+  where+  hdrs = mempty & set contentType "message/rfc822"

@@ -14,6 +14,9 @@ * @utf-8@ * @iso-8859-1@ +See also the <https://github.com/purebred-mua/purebred-icu purebred-icu>+plugin, which adds support for many character sets.+ -} module Data.MIME.Charset   (@@ -31,7 +34,7 @@   , decodeLenient   ) where -import Control.Lens (Getter, Prism', prism', review, to, view)+import Control.Lens import qualified Data.ByteString as B import qualified Data.CaseInsensitive as CI import qualified Data.Text as T@@ -80,7 +83,11 @@   charsetData :: Getter a B.ByteString    -- | Structure with the encoded data replaced with 'Text'-  charsetDecoded :: AsCharsetError e => CharsetLookup -> Getter a (Either e (Decoded a))+  charsetDecoded+    :: AsCharsetError e+    => CharsetLookup+    -> ( forall p f. (Profunctor p, Contravariant f)+        => Optic' p f a (Either e (Decoded a)) )    -- | Encode the data   charsetEncode :: Decoded a -> a@@ -88,8 +95,8 @@  -- | Decode the object according to the declared charset. charsetText-  :: (HasCharset a, AsCharsetError e)-  => CharsetLookup -> Getter a (Either e T.Text)+  :: (HasCharset a, AsCharsetError e, Profunctor p, Contravariant f)+  => CharsetLookup -> Optic' p f a (Either e T.Text) charsetText lookupCharset = to $ \a ->   maybe (Left $ review _CharsetUnspecified ()) Right (view charsetName a)   >>= \k -> maybe (Left $ review _CharsetUnsupported k) Right (lookupCharset k)@@ -97,17 +104,17 @@  -- | Monomorphic in error type charsetText'-  :: (HasCharset a)+  :: (HasCharset a, Profunctor p, Contravariant f)   => CharsetLookup-  -> Getter a (Either CharsetError T.Text)+  -> Optic' p f a (Either CharsetError T.Text) charsetText' = charsetText  -- | Prism for charset decoded/encoded data. -- Information about decoding failures is discarded. charsetPrism :: forall a. (HasCharset a) => CharsetLookup -> Prism' a (Decoded a)-charsetPrism m = prism' charsetEncode (either (const Nothing) Just . view l)+charsetPrism m = prism' charsetEncode (either err Just . view (charsetDecoded m))   where-  l = charsetDecoded m :: Getter a (Either CharsetError (Decoded a))+  err = const Nothing :: CharsetError -> Maybe x  charsets :: [(CI.CI B.ByteString, Charset)] charsets =

@@ -42,6 +42,7 @@   transferEncodedData = to _encodedWordText   transferDecoded = to $ \a@(EncodedWord charset lang _ _) ->     TransferDecodedEncodedWord charset lang <$> view transferDecodedBytes a+  transferEncode = transferEncodeEncodedWord   data TransferDecodedEncodedWord = TransferDecodedEncodedWord

@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}@@ -39,6 +40,7 @@ import Data.Foldable (fold) import Data.Functor (($>)) import Data.Semigroup ((<>), Sum(..), Max(..))+import Data.String (IsString(..)) import Data.Word (Word8) import Data.Void (Void) import Foreign (withForeignPtr, plusPtr, minusPtr, peek, peekByteOff, poke)@@ -47,6 +49,7 @@  import Control.DeepSeq (NFData) import Control.Lens+import Control.Lens.Cons.Extras (recons) import Data.Attoparsec.ByteString.Char8 hiding (take) import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B@@ -67,6 +70,12 @@ newtype Parameters = Parameters [(CI B.ByteString, B.ByteString)]   deriving (Eq, Show, Generic, NFData) +instance Semigroup Parameters where+  Parameters a <> Parameters b = Parameters (a <> b)++instance Monoid Parameters where+  mempty = Parameters []+ type instance Index Parameters = CI B.ByteString type instance IxValue Parameters = EncodedParameterValue @@ -171,6 +180,15 @@ type EncodedParameterValue = ParameterValue CharsetName B.ByteString type DecodedParameterValue = ParameterValue Void T.Text +-- | Parameter value with no language.+instance IsString DecodedParameterValue where+  fromString = ParameterValue Nothing Nothing . T.pack++-- | Parameter value with no language, encoded either in @us-ascii@+-- or @utf-8.+instance IsString EncodedParameterValue where+  fromString = charsetEncode . fromString+ value :: Lens (ParameterValue cs a) (ParameterValue cs b) a b value f (ParameterValue a b c) = ParameterValue a b <$> f c @@ -182,8 +200,8 @@ -- If you need to to specify language, use the 'ParameterValue' -- constructor directly. ---newParameter :: T.Text -> EncodedParameterValue-newParameter = charsetEncode . ParameterValue Nothing Nothing+newParameter :: Cons s s Char Char => s -> EncodedParameterValue+newParameter = charsetEncode . ParameterValue Nothing Nothing . view recons   -- | The default charset @us-ascii@ is implied by the abstract of

@@ -12,6 +12,9 @@   (     contentTransferEncodingQuotedPrintable   , q+  , QuotedPrintableMode(..)+  , encodingRequiredEOL+  , encodingRequiredNonEOL   ) where  import Control.Lens (APrism', prism')

@@ -13,20 +13,21 @@   , TransferEncodingName   , transferDecodedBytes   , transferEncodings-  , transferEncodeData   , TransferEncodingError(..)   , AsTransferEncodingError(..)   , TransferEncoding+  , chooseTransferEncoding   ) where +import Data.Monoid (Sum(Sum), Any(Any))+ import Control.Lens-  ( APrism', Getter, Prism', clonePrism, preview, prism', review, to, view ) import qualified Data.ByteString as B+import Data.ByteString.Lens (bytes) import qualified Data.CaseInsensitive as CI  import Data.MIME.Base64 import Data.MIME.QuotedPrintable-import Data.MIME.Types (Encoding(..))  type TransferEncodingName = CI.CI B.ByteString type TransferEncoding = APrism' B.ByteString B.ByteString@@ -52,6 +53,7 @@       TransferDecodeError k -> Just k ; _ -> Nothing  +-- | Data types that can have /transfer encoding/. class HasTransferEncoding a where   type TransferDecoded a @@ -62,12 +64,23 @@   transferEncodedData :: Getter a B.ByteString    -- | Perform content transfer decoding.-  transferDecoded :: AsTransferEncodingError e => Getter a (Either e (TransferDecoded a))+  transferDecoded+    :: (AsTransferEncodingError e, Profunctor p, Contravariant f)+    => Optic' p f a (Either e (TransferDecoded a)) +  -- | Perform content transfer decoding (monomorphic error type).+  transferDecoded'+    :: (Profunctor p, Contravariant f)+    => Optic' p f a (Either TransferEncodingError (TransferDecoded a))+  transferDecoded' = transferDecoded++  -- | Encode the data+  transferEncode :: TransferDecoded a -> a+ -- | Decode the object according to the declared content transfer encoding. transferDecodedBytes-  :: (HasTransferEncoding a, AsTransferEncodingError e)-  => Getter a (Either e B.ByteString)+  :: (HasTransferEncoding a, AsTransferEncodingError e, Profunctor p, Contravariant f)+  => Optic' p f a (Either e B.ByteString) transferDecodedBytes = to $ \a -> do   let encName = view transferEncodingName a   enc <- maybe (Left $ review _TransferEncodingUnsupported encName) Right@@ -93,6 +106,21 @@   , ("b", contentTransferEncodingBase64)   ] -transferEncodeData :: Encoding -> B.ByteString -> B.ByteString-transferEncodeData Base64 = contentTransferEncodeBase64-transferEncodeData _ = id+-- | Inspect the data and choose a transfer encoding to use: @7bit@+-- if the data can be transmitted as-is, otherwise whichever of+-- @quoted-printable@ or @base64@ should result in smaller output.+--+chooseTransferEncoding :: B.ByteString -> (TransferEncodingName, TransferEncoding)+chooseTransferEncoding s+  -- TODO: does not handle max line length of 998+  | not doEnc = ("7bit", id)+  | nQP < nB64 = ("quoted-printable", contentTransferEncodingQuotedPrintable)+  | otherwise = ("base64", contentTransferEncodingBase64)+  where+    -- https://tools.ietf.org/html/rfc5322#section-3.5 'text'+    needEnc c = c > 127 || c == 0+    qpBytes c+      | encodingRequiredNonEOL QuotedPrintable 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

@@ -4,13 +4,11 @@   (     ContentTransferEncoding   , EncodedWordEncoding-  , Encoding(..)   ) where  import Control.Lens (APrism') import qualified Data.ByteString as B  type ContentTransferEncoding = APrism' B.ByteString B.ByteString-data Encoding = None | Base64  type EncodedWordEncoding = APrism' B.ByteString B.ByteString

@@ -60,12 +60,18 @@   -- * Message types     Message(..)   , message-  , headers-  , headerList+  , MessageContext   , body-  , Headers(..)+  , EqMessage(..)++  -- ** Headers   , Header+  , HasHeaders(..)   , header+  , headerList+  , Headers(..)++  -- ** Addresses   , Address(..)   , address   , addressList@@ -127,6 +133,18 @@ newtype Headers = Headers [Header]   deriving (Eq, Show, Generic, NFData) +instance Semigroup Headers where+  Headers a <> Headers b = Headers (a <> b)++instance Monoid Headers where+  mempty = Headers []++class HasHeaders a where+  headers :: Lens' a Headers++instance HasHeaders Headers where+  headers = id+ type instance Index Headers = CI B.ByteString type instance IxValue Headers = B.ByteString @@ -151,9 +169,9 @@         g <$> f (lookup k kv)  --- | Get all values of the given header-header :: CI B.ByteString -> Traversal' Headers B.ByteString-header k = hdriso . traversed . filtered ((k ==) . fst) . _2+-- | Target all values of the given header+header :: HasHeaders a => CI B.ByteString -> Traversal' a B.ByteString+header k = headerList . traversed . filtered ((k ==) . fst) . _2  -- | Message type, parameterised over context and body type.  The -- context type is not used in this module but is provided for uses@@ -161,14 +179,28 @@ -- messages. -- data Message s a = Message Headers a-  deriving (Eq, Show, Generic, NFData)+  deriving (Show, Generic, NFData) -headers :: Lens' (Message s a) Headers-headers f (Message h b) = fmap (\h' -> Message h' b) (f h)-{-# ANN headers ("HLint: ignore Avoid lambda" :: String) #-}+instance HasHeaders (Message s a) where+  headers f (Message h b) = fmap (`Message` b) (f h) +instance Functor (Message s) where+  fmap f (Message h a) = Message h (f a)++-- | How to compare messages with this body type.+--+-- This class arises because we may want to tweak the headers,+-- possibly in response to body data, or vice-versa, when+-- comparing messages.+--+class EqMessage a where+  eqMessage :: Message s a -> Message s a -> Bool++instance EqMessage a => Eq (Message s a) where+  (==) = eqMessage+ -- | Access headers as a list of key/value pairs.-headerList :: Lens' (Message s a) [(CI B.ByteString, B.ByteString)]+headerList :: HasHeaders a => Lens' a [(CI B.ByteString, B.ByteString)] headerList = headers . coerced  body :: Lens (Message ctx a) (Message ctx' b) a b@@ -273,8 +305,11 @@ -- This parser does not handle the legitimate but obscure case -- of a message with no body (empty body is fine, though). ---message :: (Headers -> Parser a) -> Parser (Message s a)+message :: (Headers -> Parser a) -> Parser (Message (MessageContext a) a) message f = fields >>= \hdrs -> Message hdrs <$> (crlf *> f hdrs)++type family MessageContext a = s+  fields :: Parser Headers fields = Headers <$> many field

@@ -167,9 +167,8 @@ -- WSP."  fws :: (Alternative (f s), CharParsing f s a) => (f s) s-fws = optional (takeWhile isWsp *> crlf)-      *> takeWhile1 isWsp-      *> pure (singleton ' ')+fws = ( optional (takeWhile isWsp *> crlf) *> takeWhile1 isWsp )+      $> singleton ' '  -- | FWS collapsed to a single SPACE character, or empty string --@@ -192,7 +191,7 @@  cfws :: (Alternative (f s), CharParsing f s a, SM s) => (f s) s cfws =-  foldMany1 (optionalFWS <<>> comment) *> optionalFWS *> pure (singleton ' ')+  ((foldMany1 (optionalFWS <<>> comment) *> optionalFWS) $> singleton ' ')   <|> fws  -- | CFWS collapsed to a single SPACE character, or empty string@@ -329,20 +328,20 @@ spanTillString :: B.ByteString -> A.Parser Int spanTillString pat   | B.null pat = position-  | otherwise = go+  | otherwise = position >>= go   where   search = indices pat-  go = do-    start <- position+  go start = do+    pos <- position     buf <- takeBuffer     case search buf of       (offset:_) ->         -- Pattern was found.  Seek to end of pattern and return the span-        seek (start + offset + B.length pat) $> offset+        seek (pos + offset + B.length pat) $> pos + offset - start       _ ->         -- We hit the end of the buffer without a match.  Seek to-        -- (length buf - length pat + 1), demand more input and go again.-        seek (B.length buf - B.length pat + 1) *> A.demandInput *> go+        -- (length buf - length pat), demand more input and go again.+        seek (max start (B.length buf - B.length pat)) *> A.demandInput *> go start  -- | Efficient skip, using Boyer-Moore to locate the pattern. --

@@ -3,6 +3,8 @@  module Generator where +import Data.List.NonEmpty (fromList)+ import Test.Tasty import Test.QuickCheck.Instances () import Test.Tasty.HUnit ((@=?), testCase)@@ -75,7 +77,7 @@                 (Just "foo.bin")                 "fileContentsASDF"         now = UTCTime (ModifiedJulianDay 123) (secondsToDiffTime 123)-    in createMultipartMixedMessage "asdf" [p, a]+    in createMultipartMixedMessage "asdf" (fromList [p, a])        & set (headers . at "From") (Just $ renderMailboxes [from'])        . set (headers . at "To") (Just $ renderAddresses [to'])        . set (headers . at "Date") (Just $ renderRFC5422Date now)

@@ -81,27 +81,26 @@ rendersAddressesToTextSuccessfully =   testGroup "renders addresses to text" $   (\(desc, address, expected) ->-     testCase desc $ expected @=? (AddressText.renderAddress address)) <$>+     testCase desc $ expected @=? AddressText.renderAddress address) <$>   xs   where     xs =       [ ( "single address"-        , (Single-             (Mailbox Nothing (AddrSpec "foo" (DomainDotAtom $ pure "bar.com"))))+        , Single+            (Mailbox Nothing (AddrSpec "foo" (DomainDotAtom $ pure "bar.com")))         , "foo@bar.com")       , ( "group of addresses"-        , (Group-             "Group"+        , Group "Group"              [ Mailbox                  (Just "Mr Foo")                  (AddrSpec "foo" (DomainDotAtom $ pure "bar.com"))              , Mailbox                  (Just "Mr Bar")                  (AddrSpec "bar" (DomainDotAtom $ pure "bar.com"))-             ])+             ]         , "Group:\"Mr Foo\" <foo@bar.com>, \"Mr Bar\" <bar@bar.com>;")       , ( "group of undisclosed recipients"-        , (Group "undisclosed-recipients" [])+        , Group "undisclosed-recipients" []         , "undisclosed-recipients:;")       ] @@ -257,11 +256,12 @@         (Headers [("Content-Type", "application/x-stuff; title*0*=us-ascii'en'This%20is%20even%20more%20; title*1*=%2A%2A%2Afun%2A%2A%2A%20; title*2=\"isn't it!\"")])       @?= Just (ParameterValue (Just "us-ascii") (Just "en") "This is even more ***fun*** isn't it!")   , testCase "set filename parameter in Content-Disposition" $-      set (contentDisposition . parameter "filename") (Just (ParameterValue Nothing Nothing "foo.pdf"))+      set (contentDisposition . traversed . parameter "filename")+        (Just (ParameterValue Nothing Nothing "foo.pdf"))         (Headers [("Content-Disposition", "attachment")])       @?= Headers [("Content-Disposition", "attachment; filename=foo.pdf")]   , testCase "unset filename parameter in Content-Disposition" $-      set (contentDisposition . parameter "filename") Nothing+      set (contentDisposition . traversed . parameter "filename") Nothing         (Headers [("Content-Disposition", "attachment; foo=bar; filename=foo.pdf")])       @?= Headers [("Content-Disposition", "attachment; foo=bar")]   ]@@ -310,7 +310,7 @@  -- | Generate headers genFieldItem :: Gen B.ByteString-genFieldItem = resize 55 $ listOf1 (suchThat arbitrary isFtext) >>= pure . B.pack+genFieldItem = resize 55 . B.pack <$> listOf1 (suchThat arbitrary isFtext)  isFtext :: Word8 -> Bool isFtext c = (c >= 33 && c <= 57) || (c >= 59 && c <= 126)

@@ -19,24 +19,32 @@  module MIME where +import Control.Exception (ErrorCall, evaluate, try) import Control.Monad ((<=<), void)+import Data.Bifunctor (first) import Data.Char (toUpper)+import Data.Either (isLeft)+import Data.List.NonEmpty (fromList)+import Data.String (fromString)  import Control.Lens import qualified Data.ByteString as B import qualified Data.Text as T  import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit ((@?=), Assertion, assertFailure, testCase)+import Test.Tasty.HUnit ((@?=), Assertion, assertBool, assertFailure, testCase) import Test.Tasty.QuickCheck import Test.QuickCheck.Instances ()  import Data.MIME+import Data.MIME.Charset  unittests :: TestTree unittests = testGroup "MIME tests"   [ testContentDisposition   , testParse+  , testParameterValueOverloadedStrings+  , testContentTypeOverloadedStrings   ]  testContentDisposition :: TestTree@@ -123,15 +131,17 @@         (Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part ""))         == Just s     , testCase "unset multiple filenames" $-        set (attachments . headers . contentDisposition . filenameParameter) Nothing-        (Message (Headers []) (Multipart+        set+          (attachments . headers . contentDisposition . traversed . filenameParameter)+          Nothing+        (Message (Headers []) (Multipart . fromList $           [ Message (Headers [("Content-Disposition", "inline; filename=msg.txt")]) (Part "")           , Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part "")           , Message (Headers [("Content-Disposition", "attachment; filename=bar.pdf")]) (Part "")           ]         ))         @?=-        Message (Headers []) (Multipart+        Message (Headers []) (Multipart . fromList $           [ Message (Headers [("Content-Disposition", "inline; filename=msg.txt")]) (Part "")           , Message (Headers [("Content-Disposition", "attachment")]) (Part "")           , Message (Headers [("Content-Disposition", "attachment")]) (Part "")@@ -139,7 +149,7 @@         )     ]   where-    lFilename = headers . contentDisposition . filename defaultCharsets+    lFilename = headers . contentDisposition . traversed . filename defaultCharsets     stripPath = snd . T.breakOnEnd "/"  testParse :: TestTree@@ -151,3 +161,33 @@ testParseFile :: FilePath -> Assertion testParseFile =   either assertFailure (void . pure) . parse (message mime) <=< B.readFile++testParameterValueOverloadedStrings :: TestTree+testParameterValueOverloadedStrings = testGroup "ParameterValue IsString instances"+  [ testCase "DecodedParameterValue" $+      let+        -- start with DecodedParameterValue, then round-trip it+        v' = charsetEncode "hello世界" :: EncodedParameterValue+      in+        meh (view (charsetDecoded defaultCharsets) v')+          @?= Right (ParameterValue Nothing Nothing "hello世界")+  , testCase "EncodedParameterValue" $+      let+        -- start with EncodedParameterValue, then decode it+        v = "hello世界" :: EncodedParameterValue+      in+        meh (view (charsetDecoded defaultCharsets) v)+          @?= Right (ParameterValue Nothing Nothing "hello世界")+  ]+  where+    meh :: Either CharsetError b -> Either () b+    meh = first (const ())++testContentTypeOverloadedStrings :: TestTree+testContentTypeOverloadedStrings = testGroup "ContentType fromString"+  [ testCase "no params" $ fromString "foo/bar" @?= ContentType "foo" "bar" mempty+  , testCase "params" $ fromString "foo/bar; baz=quux" @?= ContentType "foo" "bar" (Parameters [("baz", "quux")])+  , testCase "bogus" $+      (isLeft <$> (try . evaluate $ fromString "foo/; baz=quux" :: IO (Either ErrorCall ContentType)))+      >>= assertBool "bogus string throws error"+  ]

@@ -0,0 +1,90 @@+-- This file is part of purebred-email+-- Copyright (C) 2019  Fraser Tweedale+--+-- purebred-email is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- 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/>.++{- |++Generators and instances for messages and parts thereof.++-}+module Message where++import Data.Char (isAscii, isPrint)+import Data.List.NonEmpty (fromList)++import qualified Data.ByteString.Char8 as B+import qualified Data.Text as T++import Test.Tasty+import Test.Tasty.QuickCheck++import Data.MIME++tests :: TestTree+tests = testGroup "message tests"+  [ testProperty "message round trip" prop_messageRoundTrip+  ]++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++genTextPlain :: Gen MIMEMessage+genTextPlain = createTextPlainMessage <$> oneof [genAscii1, genText1]++-- 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++-- Multipart message with at least one part.+genMultipart1 = depths >>= go+  where+  go :: Int -> Gen MIMEMessage+  go 0 = genTextPlain+  go n = do+    len <- choose (1, 10) -- up to 10 subparts, minimum of 1+    createMultipartMixedMessage+      <$> genBoundary+      <*> ( fromList <$>+            -- 75% plain, 25% nested multipart+            vectorOf len (maybeAp encapsulate 5 $ frequency [(3, genTextPlain), (1, go (n - 1))])+          )++  -- max depth of 4+  depths = 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 ]+++prop_messageRoundTrip :: Property+prop_messageRoundTrip = forAll genMessage $ \msg ->+  parse (message mime) (renderMessage msg) == Right msg

@@ -0,0 +1,39 @@+-- This file is part of purebred-email+-- Copyright (C) 2019  Fraser Tweedale+--+-- purebred-email is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- 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/>.++module Parser where++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.QuickCheck++import Data.RFC5322.Internal (takeTillString)++tests :: TestTree+tests = testGroup "Parser tests"+  [ testProperty "takeTillString" $ \h l c r ->+      let+        s = h <> l <> c <> r+        s' = L.fromChunks $ B.foldr ((:) . B.singleton) [] s+      in+        not (c `B.isInfixOf` l) ==>+          case AL.parse (AL.string h *> takeTillString c) s' of+            AL.Done r' l' -> r' == L.fromStrict r && l' == l+            _ -> False+  ]

@@ -5,6 +5,8 @@ import MIME import Headers import Generator+import Parser+import Message  main :: IO () main =@@ -13,4 +15,6 @@     , Headers.unittests     , Generator.properties     , MIME.unittests+    , Parser.tests+    , Message.tests     ]

@@ -1,23 +1,20 @@+MIME-Version: 1.0
 From: "Roman Joost" <foo@bar.com>
 To: bar@bar.com
 Date: Sun, 20 Mar 1859 00:02:03 +0000
 Subject: Hello there
 Content-Type: multipart/mixed; boundary=asdf
-MIME-Version: 1.0
 
 --asdf
-Content-Type: text/plain
-Content-Disposition: inline; charset=utf-8
 Content-Transfer-Encoding: 7bit
-MIME-Version: 1.0
+Content-Disposition: inline
+Content-Type: text/plain; charset=us-ascii
 
 This is a simple mail.
 --asdf
-Content-Type: application/octet-stream
+Content-Transfer-Encoding: 7bit
 Content-Disposition: attachment; filename=foo.bin
-Content-Transfer-Encoding: base64
-MIME-Version: 1.0
-
-ZmlsZUNvbnRlbnRzQVNERg==
+Content-Type: application/octet-stream
 
+fileContentsASDF
 --asdf--

@@ -1,7 +1,7 @@+MIME-Version: 1.0
 Subject: Hello there
-Content-Type: text/plain
-Content-Disposition: inline; charset=utf-8
 Content-Transfer-Encoding: 7bit
-MIME-Version: 1.0
+Content-Disposition: inline
+Content-Type: text/plain; charset=us-ascii
 
 This is a simple mail.