purebred-email 0.6.0.2 → 0.7

raw patch · 20 files changed

+320/−128 lines, 20 filesdep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, bytestring

API changes (from Hackage documentation)

Files

• CHANGELOG.md +27/−0
• purebred-email.cabal +24/−26
• src/Data/IMF.hs +31/−13
• src/Data/IMF/Syntax.hs +28/−4
• src/Data/IMF/Text.hs +23/−1
• src/Data/MIME.hs +78/−43
• src/Data/MIME/Charset.hs +0/−3
• src/Data/MIME/EncodedWord.hs +1/−1
• src/Data/MIME/Error.hs +0/−2
• src/Data/MIME/Parameter.hs +8/−12
• src/Data/MIME/QuotedPrintable.hs +0/−1
• src/Data/MIME/TransferEncoding.hs +0/−1
• src/Data/MIME/Types.hs +0/−2
• test-vectors/multipart-no-body.eml +18/−0
• tests/ContentTransferEncodings.hs +0/−2
• tests/Generator.hs +2/−1
• tests/Headers.hs +45/−5
• tests/MIME.hs +16/−4
• tests/Message.hs +16/−4
• tools/Parse.hs +3/−3

@@ -1,3 +1,30 @@+## Version 0.7 (2025-08-31)++- Support non-ASCII UTF-8 in `Subject` and other unstructured+  headers.  ([#82])++- Support non-ASCII UTF-8 in display name in the `Data.IMF.Text`+  parser (the `ByteString` parser still only supports non-ASCII+  input via encoded-word).  ([#87])++- Export `contentTypeMultipart` so that users can create all kinds+  of multipart messages. ([#81])++- Add `headerAuthor`, for and reading the `Author:` header field+  defined in [RFC 9057]. ([#77])++- Add support for parsing MIME subparts without bodies.  The new+  `entities'` traversal visits all parts, projecting `Just body`+  where there is a body otherwise `Nothing`.  The `MIME` data type+  gets the new `PartNoBody` constructor.  ([#90])++[#77]: https://github.com/purebred-mua/purebred-email/issues/77+[#81]: https://github.com/purebred-mua/purebred-email/issues/81+[#82]: https://github.com/purebred-mua/purebred-email/issues/82+[#87]: https://github.com/purebred-mua/purebred-email/issues/87+[#90]: https://github.com/purebred-mua/purebred-email/issues/90++ ## Version 0.6 (2022-09-13)  - Parameterise the `ContentType` data type over the "parameters"

@@ -1,6 +1,6 @@ cabal-version:       2.2 name:                purebred-email-version:             0.6.0.2+version:             0.7 synopsis:            types and parser for email messages (including MIME) description:   The purebred email library.  RFC 5322, MIME, etc.@@ -23,6 +23,7 @@   - MIME parameter value and encoded word extensions (<https://tools.ietf.org/html/rfc2231 RFC 2231>)   - @Content-Disposition@ header field (<https://tools.ietf.org/html/rfc2183 RFC 2183>)   - Address syntax in @From@ and @Sender@ fields (<https://tools.ietf.org/html/rfc6854 RFC 6854>)+  - @Author@ header field (<https://tools.ietf.org/html/rfc9057 RFC 9057>)  license:             AGPL-3.0-or-later license-file:        LICENSE@@ -31,13 +32,14 @@ copyright:           Copyright 2017-2021  Fraser Tweedale category:            Data, Email build-type:          Simple-extra-source-files:+extra-doc-files:   CHANGELOG.md   README.rst+extra-source-files:   test-vectors/*.eml   tests/golden/*.golden tested-with:-  GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.7 || ==9.6.3 || ==9.8.1+  GHC ==9.6.7 || ==9.8.4 || ==9.10.2 || ==9.12.2 || ==9.14.1  homepage:            https://github.com/purebred-mua/purebred-email bug-reports:         https://github.com/purebred-mua/purebred-email/issues@@ -49,8 +51,9 @@   description: Build demonstration programs   default: False -common common-  default-language: Haskell2010+common language+  default-language: GHC2021+  default-extensions: LambdaCase   ghc-options:     -Wall     -Wcompat@@ -63,24 +66,17 @@     -Wpartial-fields     -Wredundant-constraints     -fhide-source-paths-  if impl(ghc >= 8.10)-    ghc-options:-      -Wunused-packages-  if impl(ghc >= 9.0)-    ghc-options:-      -Winvalid-haddock-      -Werror=unicode-bidirectional-format-characters-  if impl(ghc >= 9.2)-    ghc-options:-      -Wimplicit-lift-      -Woperator-whitespace-      -Wredundant-bang-patterns-  if impl(ghc >= 9.4)-    ghc-options:-      -Wredundant-strictness-flags+    -Wunused-packages+    -Winvalid-haddock+    -Werror=unicode-bidirectional-format-characters+    -Wimplicit-lift+    -Woperator-whitespace+    -Wredundant-bang-patterns+    -Wredundant-strictness-flags +common deps   build-depends:-    base >= 4.11 && < 5+    base >= 4.18 && < 5     , attoparsec >= 0.13 && < 0.15     , bytestring >= 0.10 && < 0.13     , case-insensitive >= 1.2 && < 1.3@@ -89,7 +85,8 @@     , time >= 1.9  library-  import: common+  import: language+  import: deps   exposed-modules:     Data.IMF     , Data.IMF.Syntax@@ -113,17 +110,16 @@     , Data.IMF.DateTime   build-depends:     , base64-bytestring >= 1 && < 2-    , case-insensitive >= 1.2 && < 1.3     , concise >= 0.1.0.1 && < 1     , deepseq >= 1.4.2     , random >= 1.2.0     , semigroupoids >= 5 && < 7     , stringsearch >= 0.3   hs-source-dirs:      src-  default-language:    Haskell2010  test-suite tests-  import: common+  import: language+  import: deps   type: exitcode-stdio-1.0   hs-source-dirs: tests   main-is: Test.hs@@ -147,10 +143,12 @@     , quickcheck-instances  executable purebred-email-parse-  import: common+  import: language   if !flag(demos)     buildable: False   hs-source-dirs: tools   main-is: Parse.hs   build-depends:+    base+    , bytestring     , purebred-email

@@ -14,16 +14,10 @@ -- 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 AllowAmbiguousTypes #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}  {- |@@ -119,6 +113,7 @@    -- ** Originator   , headerFrom+  , headerAuthor   , headerReplyTo    -- ** Destination Address@@ -150,6 +145,7 @@   , Address(..)   , address   , addressList+  , addressSpec   , AddrSpec(..)   , Domain(..)   , Mailbox(..)@@ -211,7 +207,7 @@   ( CI, ci, mk, original   , (<<>>), foldMany, foldMany1Sep   , char, fromChar, isAtext, isQtext, isVchar, isWsp-  , optionalCFWS, word, wsp, vchar, optionalFWS, crlf+  , optionalCFWS, word, wsp, vcharUtf8, optionalFWS, crlf   , domainLiteral, dotAtom, dotAtomText, localPart, quotedString   ) import {-# SOURCE #-} Data.IMF.Text (readMailbox)@@ -222,7 +218,8 @@  type Header = (CI B.ByteString, B.ByteString) newtype Headers = Headers [Header]-  deriving (Eq, Show, Generic, NFData)+  deriving (Eq, Show, Generic)+  deriving anyclass (NFData)  class HasHeaders a where   headers :: Lens' a Headers@@ -513,6 +510,26 @@ headerCC = headerAddressList "Cc" headerBCC = headerAddressList "Bcc" +-- | @Author:@ field (<https://tools.ietf.org/html/rfc9057 RFC 9057>).+--+-- Rules for this field:+--+-- * If an Author: field already exists, a new one MUST NOT be+--   created, and the existing one MUST NOT be modified.+-- * An author's MUA or MSA MAY create an Author: field, and its+--   value MUST be identical to the value in the From: field.+-- * A Mediator MAY create an Author: field if one does not already+--   exist, and this new field's value MUST be identical to the value+--   of the From: field at the time the Mediator received the message+--   (and before the Mediator causes any changes to the From: field).+--+-- This implementation follows RFC 6854 in allowing group syntax+-- (RFC 9057 defines a more strict syntax, which is incompatible+-- with RFC 6854).+--+headerAuthor :: (HasHeaders a) => CharsetLookup -> Lens' a [Address]+headerAuthor = headerAddressList "Author"+ data MessageID = MessageID   (NonEmpty B.ByteString)   (Either (NonEmpty B.ByteString) B.ByteString)@@ -681,10 +698,10 @@   inRep = view headerInReplyTo msg  replySubject :: CharsetLookup -> Message ctx a -> T.Text-replySubject charsets msg = if prefixed then orig else "Re: " <> orig+replySubject charsets msg = if hasPrefix then orig else "Re: " <> orig   where   orig = fold $ view (headerSubject charsets) msg-  prefixed = mk (T.take 3 orig) == "Re:"+  hasPrefix = mk (T.take 3 orig) == "Re:"   -- | Construct a reply to a 'Message', according to the specified@@ -744,7 +761,7 @@     getAddrSpec :: Mailbox -> AddrSpec     getAddrSpec (Mailbox _ addr) = addr -    -- | Find a mailbox matching the given address.  If no match is+    -- Find a mailbox matching the given address.  If no match is     -- found, return @Nothing@.  If match is found, return the value     -- from the candidates collection if 'ReplyFromRewriteOn',     -- otherwise return the input value.@@ -899,9 +916,10 @@   <*  char8 ':' <* many wsp   <*> unstructured <* crlf +-- | UTF-8 unstructured text unstructured :: Parser B.ByteString unstructured =-  foldMany (optionalFWS <<>> (B.singleton <$> vchar))+  foldMany (optionalFWS <<>> fmap B.pack vcharUtf8)   <<>> A.takeWhile isWsp  

@@ -14,11 +14,8 @@ -- 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 ConstraintKinds #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}  {- | @@ -43,6 +40,7 @@   , crlf   , vchar   , word+  , dquote   , quotedString   , dotAtomText   , dotAtom@@ -53,6 +51,8 @@   , CharParsing(..)   , SM +  , vcharUtf8+   -- ** Helpers for building parsers   , isAtext   , isQtext@@ -76,7 +76,7 @@   ) where  import Prelude hiding (takeWhile)-import Control.Applicative ((<|>), Alternative, liftA2, many, optional, some)+import Control.Applicative ((<|>), Alternative, many, optional, some) import Control.Monad (void) import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.Internal as A@@ -145,6 +145,30 @@  vchar :: CharParsing f s a => (f s) a vchar = satisfy isVchar++vcharUtf8 :: AT.Parser B.ByteString [Word8]+vcharUtf8 =+  pure <$> satisfy isVchar+  <|> utf8NonAscii++-- | Parse a multi-byte UTF-8 character, returning the list of+-- bytes.+utf8NonAscii :: A.Parser [Word8]+utf8NonAscii =+  list2 <$> fromTo 0xC2 0xDF <*> utf8_tail+  <|> list3 <$> A.word8 0xE0 <*> fromTo 0xA0 0xBF <*> utf8_tail+  <|> list3 <$> fromTo 0xE1 0xEC <*> utf8_tail <*> utf8_tail+  <|> list3 <$> A.word8 0xED <*> fromTo 0x80 0x9F <*> utf8_tail+  <|> list3 <$> fromTo 0xEE 0xEF <*> utf8_tail <*> utf8_tail+  <|> list4 <$> A.word8 0xF0 <*> fromTo 0x90 0xBF <*> utf8_tail <*> utf8_tail+  <|> list4 <$> fromTo 0xF1 0xF3 <*> utf8_tail <*> utf8_tail <*> utf8_tail+  <|> list4 <$> fromTo 0xF1 0xF3 <*> utf8_tail <*> utf8_tail <*> utf8_tail+  where+    fromTo lo hi = A.satisfy (\c -> c >= lo && c <= hi)+    utf8_tail = fromTo 0x80 0xBF+    list2 c1 c2 = [c1, c2]+    list3 c1 c2 c3 = [c1, c2, c3]+    list4 c1 c2 c3 c4 = [c1, c2, c3, c4]  dquote :: CharParsing f s a => (f s) a dquote = char '"'

@@ -49,7 +49,7 @@  import Data.MIME.Charset (decodeLenient) import Data.IMF (Mailbox(..), Address(..), AddrSpec(..), Domain(..))-import Data.IMF.Syntax+import Data.IMF.Syntax hiding (quotedString, word)   renderMailboxes :: [Mailbox] -> T.Text@@ -98,6 +98,28 @@ -- | Parse a (whole) string, returning an error @String@ or a 'Mailbox'. readMailbox :: String -> Either String Mailbox readMailbox = parseOnly (mailbox <* endOfInput) . T.pack++isUtf8NonAscii :: Char -> Bool+isUtf8NonAscii = (> '\127')++quotedString :: Parser T.Text+quotedString =+  optionalCFWS *> dquote+  *> foldMany (optionalFWS <<>> qcontent) <<>> optionalFWS+  <* dquote <* optionalCFWS+  where+    qcontent =+      T.singleton <$> A.satisfy (\c -> isQtext c || isUtf8NonAscii c)+      <|> T.singleton <$> quotedPair++quotedPair :: Parser Char+quotedPair = char '\\' *> (vchar <|> A.satisfy isUtf8NonAscii <|> wsp)++atom :: Parser T.Text+atom = optionalCFWS *> A.takeWhile1 (\c -> isAtext c || isUtf8NonAscii c) <* optionalCFWS++word :: Parser T.Text+word = atom <|> quotedString  -- | Version of 'phrase' that does not process encoded-word -- (we are parsing Text so will assume that the input does not

@@ -15,11 +15,7 @@ -- along with this program.  If not, see <http://www.gnu.org/licenses/>.  {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-}  {- |@@ -58,6 +54,7 @@    -- *** Accessing and processing entities   , entities+  , entities'   , attachments   , isAttachment   , transferDecoded@@ -91,6 +88,7 @@   -- *** Content-Type values   , contentTypeTextPlain   , contentTypeApplicationOctetStream+  , contentTypeMultipart   , contentTypeMultipartMixed   , defaultContentType @@ -497,6 +495,7 @@ -- data MIME   = Part B.ByteString+  | PartNoBody   | Encapsulated MIMEMessage   | Multipart MultipartSubtype Boundary (NonEmpty MIMEMessage)   | FailedParse MIMEParseError B.ByteString@@ -509,16 +508,35 @@     where     stripVer = set (headers . at "MIME-Version") Nothing --- | Get all leaf entities from the MIME message.--- Entities that failed to parse are skipped.+-- | Traverse all leaf entities in the MIME message.+-- Skips parts without a body and parts that failed to parse. --+-- Use 'entities'' to also traverse parts that do not have a body.+-- entities :: Traversal' MIMEMessage WireEntity-entities f (Message h a) = case a of+entities = entities' . l+  where+  l f (Message h mb) = case mb of+    Nothing -> pure (Message h mb)+    Just b  -> fmap Just <$> f (Message h b)++-- | Traverse all leaf parts in the MIME message, projecting+-- @Just body@ where there is a body and @Nothing@ where there is+-- no body.  Skips parts that failed to parse.+--+-- Use 'entities' to traverse only the parts with bodies.+--+entities' :: Traversal' MIMEMessage (Message EncStateWire (Maybe B.ByteString))+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+    (\(Message h' b') -> Message h' (maybe PartNoBody Part b'))+    <$> f (Message h (Just b))+  PartNoBody ->+    (\(Message h' b') -> Message h' (maybe PartNoBody Part b'))+    <$> f (Message h Nothing)+  Encapsulated msg -> Message h . Encapsulated <$> entities' f msg   Multipart sub b bs ->-    Message h . Multipart sub b <$> traverse (entities f) bs+    Message h . Multipart sub b <$> traverse (entities' f) bs   FailedParse _ _ -> pure (Message h a)  -- | Leaf entities with @Content-Disposition: attachment@@@ -675,6 +693,9 @@ --   Decoding RTF is outside the scope of this library. --   See <https://www.iana.org/assignments/media-types/text/rtf>. --+-- For encoding, uses @us-ascii@ if the body is entierly ASCII+-- otherwise @utf-8@, and sets the @charset@ parameter accordingly.+-- instance HasCharset ByteEntity where   type Decoded ByteEntity = TextEntity   charsetName = to $ \ent ->@@ -693,12 +714,6 @@   charsetData = body   charsetDecoded m = to $ \a -> (\t -> set body t a) <$> view (charsetText m) a -  -- | Encode (@utf-8@) and add/set charset parameter.  If consisting-  -- entirely of ASCII characters, the @charset@ parameter gets set to-  -- @us-ascii@ instead of @utf-8@.-  ---  -- Ignores Content-Type (which is not correct for all content types).-  --   charsetEncode (Message h a) =     let       b = T.encodeUtf8 a@@ -961,30 +976,54 @@ -- mime :: Headers -> BodyHandler MIME mime h-  | nullOf (header "MIME-Version") h = RequiredBody (Part <$> takeByteString)-  | otherwise = mime' takeByteString h+  | nullOf (header "MIME-Version") h = OptionalBody (Part <$> takeByteString, PartNoBody)+  | otherwise = mime' Top h  type instance MessageContext MIME = EncStateWire +data MIMELevel = Top | Nest B.ByteString {- delimiter -}+ mime'-  :: Parser B.ByteString-  -- ^ Parser FOR A TAKE to the part delimiter.  If this part is-  -- multipart, we pass it on to the 'multipart' parser.  If this-  -- part is not multipart, we just do the take.+  :: MIMELevel -- ^ current level of message   -> Headers   -> BodyHandler MIME-mime' takeTillEnd h = RequiredBody $ case view contentType h of-  ct | view ctType ct == "multipart" ->+mime' level h = case view contentType h of+  ct | view ctType ct == "multipart"+     -> RequiredBody $         case prepMultipart ct of-          Left err              -> FailedParse err <$> takeTillEnd+          Left err              -> FailedParse err <$> takeCRLF           Right (sub, boundary) ->-            Multipart sub boundary <$> multipart takeTillEnd boundary-            <|> FailedParse MultipartParseFail <$> takeTillEnd-     | matchContentType "message" (Just "rfc822") ct ->-        (Encapsulated <$> message (mime' takeTillEnd))-        <|> (FailedParse EncapsulatedMessageParseFail <$> takeTillEnd)-  _ -> Part <$> takeTillEnd+            Multipart sub boundary <$> multipart takeCRLF boundary+            <|> FailedParse MultipartParseFail <$> takeCRLF+     | matchContentType "message" (Just "rfc822") ct+     -> RequiredBody $+          Encapsulated <$> message (mime' level)+          <|> FailedParse EncapsulatedMessageParseFail <$> takeCRLF+  _ -> OptionalBody+        ( case level of+            Top ->+              Part <$> takeByteString+            Nest boundary ->+              takeTillString boundary >>= \case+                -- special case: we are already at the boundary!+                -- this is not an empty body; it is NO BODY+                "" -> pure PartNoBody+                -- we took to the boundary, but need to trim the CRLF+                s -> pure $ Part (trimCRLF s)++        , PartNoBody+        )   where+    trimCRLF s+      | C8.takeEnd 2 s == "\r\n" = B.dropEnd 2 s+      | C8.takeEnd 1 s ==   "\n" = B.dropEnd 1 s+      | otherwise                =             s+    trimCR s+      | C8.takeEnd 1 s == "\r" = B.dropEnd 1 s+      | otherwise              =             s+    takeCRLF = case level of+      Top -> takeByteString+      Nest boundary -> trimCR <$> takeTillString ("\n" <> boundary)     prepMultipart ct =       (,) <$> parseSubtype ct <*> parseBoundary ct     parseBoundary ct =@@ -1037,13 +1076,8 @@   *> fmap fromList (part `sepBy1` crlf)   <* string "--" <* takeTillEnd   where-    delimiter = "\n--" <> unBoundary boundary-    dashBoundary = B.tail delimiter-    part = message (mime' (trim <$> takeTillString delimiter))-    trim s  -- trim trailing CR, because we only searched for LF-      | B.null s = s-      | C8.last s == '\r' = B.init s-      | otherwise = s+    dashBoundary = "--" <> unBoundary boundary+    part = message (mime' (Nest dashBoundary))  -- | Sets the @MIME-Version: 1.0@ header. --@@ -1057,17 +1091,18 @@         Multipart sub boundary _  -> set contentType (contentTypeMultipart sub boundary)         Encapsulated _msg         -> set contentType "message/rfc822"         _                         -> id-  buildBody _h z = Just $ case z of-    Part partbody -> Builder.byteString partbody-    Encapsulated msg -> buildMessage msg-    Multipart _sub b xs ->+  buildBody _h z = case z of+    Part partbody       -> Just $ Builder.byteString partbody+    PartNoBody          -> Nothing+    Encapsulated msg    -> Just $ buildMessage msg+    FailedParse _ bs    -> Just $ Builder.byteString bs+    Multipart _sub b xs -> Just $       let         boundary = "--" <> Builder.byteString (unBoundary 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  -- | Create a mixed `MIMEMessage` with an inline text/plain part and multiple -- `attachments`

@@ -14,10 +14,7 @@ -- 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 LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}  {- |

@@ -34,7 +34,7 @@   , chooseEncodedWordEncoding   ) where -import Control.Applicative ((<|>), liftA2, optional)+import Control.Applicative ((<|>), optional) import Data.Maybe (fromMaybe) import Data.Monoid (Sum(Sum), Any(Any)) 

@@ -14,8 +14,6 @@ -- 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 LambdaCase #-}- module Data.MIME.Error where  import Control.Lens (Prism', prism')

@@ -14,14 +14,9 @@ -- 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 BangPatterns #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}  {- |@@ -85,7 +80,8 @@ -- and optional charset and language information (RFC 2231). -- newtype Parameters = Parameters [(CI B.ByteString, B.ByteString)]-  deriving (Eq, Show, Generic, NFData)+  deriving (Eq, Show, Generic)+  deriving anyclass (NFData)  instance Semigroup Parameters where   Parameters a <> Parameters b = Parameters (a <> b)@@ -226,12 +222,12 @@   -- | The default charset @us-ascii@ is implied by the abstract of--- RFC 2231 which states: /This memo defines … a means to specify--- parameter values in character sets other than US-ASCII/.+-- RFC 2231 which states: /This memo defines … a means to specify/+-- /parameter values in character sets other than US-ASCII/. ----- When encoding, 'utf-8' is always used, but if the whole string--- contains only ASCII characters then the charset declaration is--- omitted (so that it can be encoded as a non-extended parameter).+-- Always encodes values in @utf-8@, but omits the @charset@+-- declaration when the string contains only ASCII characters+-- (so that it can be encoded as a non-extended parameter). -- instance HasCharset EncodedParameterValue where   type Decoded EncodedParameterValue = DecodedParameterValue

@@ -14,7 +14,6 @@ -- 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 BangPatterns #-} {-# LANGUAGE OverloadedStrings #-}  {- |

@@ -14,7 +14,6 @@ -- 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 LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} 

@@ -14,8 +14,6 @@ -- 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 RankNTypes #-}- module Data.MIME.Types   (     ContentTransferEncoding

@@ -0,0 +1,18 @@+MIME-Version: 1.0
+Content-Type: multipart/mixed; boundary="------------VGV4VA5ahWZIEkhxyIbpi2vp"
+To: test@example.com
+From: test@example.com
+Subject: Test
+
+This is a multi-part message in MIME format.
+--------------VGV4VA5ahWZIEkhxyIbpi2vp
+Content-Type: text/plain; charset=UTF-8
+Content-Transfer-Encoding: 7bit
+
+--------------VGV4VA5ahWZIEkhxyIbpi2vp
+Content-Type: text/plain; charset=UTF-8
+Content-Transfer-Encoding: 7bit
+
+Hello World
+
+--------------VGV4VA5ahWZIEkhxyIbpi2vp--

@@ -14,9 +14,7 @@ -- 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 CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}  module ContentTransferEncodings where 

@@ -14,8 +14,9 @@ -- 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/>. +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}  module Generator where 

@@ -14,8 +14,11 @@ -- 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/>. -{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {-# LANGUAGE OverloadedStrings #-}+ module Headers where  import Control.Lens@@ -23,6 +26,7 @@ import Data.String (IsString) import Data.Word (Word8) +import qualified Data.Text as T import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8@@ -47,6 +51,7 @@ unittests :: TestTree unittests = testGroup "Headers"   [ parsesMailboxesSuccessfully+  , parsesMailboxesNonASCIISuccessfully   , parsesTextMailboxesSuccessfully   , parsesAddressesSuccessfully   , parsesTextAddressesSuccessfully@@ -176,21 +181,56 @@       , assertBool "Parse error expected" . isLeft       , "foo@,bar,com")     , ( "displayName without quotes but with spaces"-      , (Right (Mailbox (Just "John Doe") (AddrSpec "jdoe" (DomainDotAtom $ "machine" :| ["example"]))) @=?)-      , "John Doe <jdoe@machine.example>"+      , (Right (Mailbox (Just "John. (Doe)") (AddrSpec "jdoe" (DomainDotAtom $ "machine" :| ["example"]))) @=?)+      , "\"John. (Doe)\" <jdoe@machine.example>"       )     ]  parsesMailboxesSuccessfully :: TestTree parsesMailboxesSuccessfully =-    testGroup "parsing mailboxes" $+    testGroup "parsing mailboxes (text)" $     (\(desc,f,input) ->           testCase desc $ f (AText.parseOnly AddressText.mailbox input)) <$>     mailboxFixtures +nonASCIIDisplayNameFixtures :: [(String, T.Text, T.Text)]+nonASCIIDisplayNameFixtures =+  [ ( "Czech (bare)"+    , "Luděk Tiberiu"+    , "Luděk Tiberiu" )+  , ( "Czech (quoted-string)"+    , "Luděk Tiberiu"+    , "\"Luděk Tiberiu\"" )+  , ( "Czech (quoted-string with quoted-pair)"+    , "Luděk Tiberiu"+    , "\"Lud\\ěk Tiberiu\"" )+  , ( "Chinese"+    , "佐藤 直樹"+    , "佐藤 直樹" )+  , ("Japanese"+    , "鈴木 一郎"+    , "鈴木 一郎" )+  , ("Korean"+    , "김철수"+    , "김철수" )+  , ("Apostrophe"+    , "O'Neill Mc Carthy"+    , "O'Neill Mc Carthy" )+  ]++parsesMailboxesNonASCIISuccessfully :: TestTree+parsesMailboxesNonASCIISuccessfully =+  testGroup "parsing mailboxes (non-ASCII)" $+  (\(desc, expect, input) ->+     testCase desc $ Right (Mailbox (Just expect) addrSpecCommon) @=? AText.parseOnly AddressText.mailbox (input <> " <foo@bar.test>")) <$>+  nonASCIIDisplayNameFixtures+  where+    addrSpecCommon = AddrSpec "foo" (DomainDotAtom $ "bar" :| ["test"])++ parsesTextMailboxesSuccessfully :: TestTree parsesTextMailboxesSuccessfully =-    testGroup "parsing mailboxes (text)" $+    testGroup "parsing mailboxes" $     (\(desc,f,input) ->           testCase desc $ f (parseOnly (mailbox defaultCharsets) input)) <$>     mailboxFixtures

@@ -14,13 +14,14 @@ -- 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/>. +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-}  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)@@ -33,7 +34,7 @@ import Data.Time (ZonedTime(ZonedTime), timeZoneMinutes)  import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit ((@?=), Assertion, assertBool, assertFailure, testCase)+import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Test.QuickCheck.Instances () @@ -159,11 +160,22 @@ testParse = testGroup "parsing tests"   [ testCase "nested multipart" $       testParseFile "test-vectors/nested-multipart.eml"+  , testCase "multipart with an empty (no body) part" $+      testParseFileAndAssert "test-vectors/multipart-no-body.eml" $ \msg ->+        assertEqual "parsed the expected sub-entities"+          [ Nothing, Just "Hello World\r\n" ]+          ( toListOf (entities' . body) msg )   ] +testParseFileAndAssert :: FilePath -> (MIMEMessage -> Assertion) -> Assertion+testParseFileAndAssert path go = do+  input <- B.readFile path+  case parse (message mime) input of+    Left s    -> assertFailure s+    Right msg -> go msg+ testParseFile :: FilePath -> Assertion-testParseFile =-  either assertFailure (void . pure) . parse (message mime) <=< B.readFile+testParseFile path = testParseFileAndAssert path (const $ pure ())  testParameterValueOverloadedStrings :: TestTree testParameterValueOverloadedStrings = testGroup "ParameterValue IsString instances"

@@ -68,8 +68,12 @@ asciiText1 = Gen.text (Range.linear 1 100) printableAsciiChar unicodeText1 = Gen.text (Range.linear 1 100) printableUnicodeChar -genTextPlain, genMultipart, genMessage :: Gen MIMEMessage+genTextPlain, genMultipart, genNoBody, genMessage :: Gen MIMEMessage+ genTextPlain = createTextPlainMessage <$> Gen.choice [asciiText1, unicodeText1]++genNoBody = pure $ set body PartNoBody $ createTextPlainMessage ""+ genMultipart = depths >>= go   where   -- Generate a 50 character multipart boundary.  These MUST be unique@@ -81,8 +85,11 @@   go n = createMultipartMixedMessage       <$> genBoundary       <*> ( Gen.nonEmpty (Range.linear 1 10) $-            -- 75% plain, 25% nested multipart-            maybeAp encapsulate 5 $ Gen.frequency [(3, genTextPlain), (1, go (n - 1))]+            maybeAp encapsulate 5 $ Gen.frequency+              [ (70, genTextPlain)+              , (10, genNoBody)+              , (20, go (n - 1))+              ]           )    -- max depth of 4@@ -97,7 +104,12 @@   -- 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 ]+genMessage = Gen.choice+  [ genTextPlain+  , genNoBody+  , genMultipart+  , encapsulate <$> genMessage+  ]  prop_messageRoundTrip :: Property prop_messageRoundTrip = property $ do

@@ -20,10 +20,10 @@   traverse_ parseMail (fileFilter files)  parseMail :: FilePath -> IO ()-parseMail filename = do-  msgData <- B.readFile filename+parseMail path = do+  msgData <- B.readFile path   case parse (message mime) msgData of-    Left e -> putStrLn (filename <> " (" <> e <> ") " <> analyse msgData)+    Left e -> putStrLn (path <> " (" <> e <> ") " <> analyse msgData)     Right _ -> pure ()  analyse :: B.ByteString -> String