diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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" diff --git a/purebred-email.cabal b/purebred-email.cabal --- a/purebred-email.cabal +++ b/purebred-email.cabal @@ -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 () - @Content-Disposition@ header field () - Address syntax in @From@ and @Sender@ fields () + - @Author@ header field () 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 diff --git a/src/Data/IMF.hs b/src/Data/IMF.hs --- a/src/Data/IMF.hs +++ b/src/Data/IMF.hs @@ -14,16 +14,10 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# 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 (). +-- +-- 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 diff --git a/src/Data/IMF/Syntax.hs b/src/Data/IMF/Syntax.hs --- a/src/Data/IMF/Syntax.hs +++ b/src/Data/IMF/Syntax.hs @@ -14,11 +14,8 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# 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 '"' diff --git a/src/Data/IMF/Text.hs b/src/Data/IMF/Text.hs --- a/src/Data/IMF/Text.hs +++ b/src/Data/IMF/Text.hs @@ -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 diff --git a/src/Data/MIME.hs b/src/Data/MIME.hs --- a/src/Data/MIME.hs +++ b/src/Data/MIME.hs @@ -15,11 +15,7 @@ -- along with this program. If not, see . {-# 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 . -- +-- 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` diff --git a/src/Data/MIME/Charset.hs b/src/Data/MIME/Charset.hs --- a/src/Data/MIME/Charset.hs +++ b/src/Data/MIME/Charset.hs @@ -14,10 +14,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {- | diff --git a/src/Data/MIME/EncodedWord.hs b/src/Data/MIME/EncodedWord.hs --- a/src/Data/MIME/EncodedWord.hs +++ b/src/Data/MIME/EncodedWord.hs @@ -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)) diff --git a/src/Data/MIME/Error.hs b/src/Data/MIME/Error.hs --- a/src/Data/MIME/Error.hs +++ b/src/Data/MIME/Error.hs @@ -14,8 +14,6 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE LambdaCase #-} - module Data.MIME.Error where import Control.Lens (Prism', prism') diff --git a/src/Data/MIME/Parameter.hs b/src/Data/MIME/Parameter.hs --- a/src/Data/MIME/Parameter.hs +++ b/src/Data/MIME/Parameter.hs @@ -14,14 +14,9 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# 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 diff --git a/src/Data/MIME/QuotedPrintable.hs b/src/Data/MIME/QuotedPrintable.hs --- a/src/Data/MIME/QuotedPrintable.hs +++ b/src/Data/MIME/QuotedPrintable.hs @@ -14,7 +14,6 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {- | diff --git a/src/Data/MIME/TransferEncoding.hs b/src/Data/MIME/TransferEncoding.hs --- a/src/Data/MIME/TransferEncoding.hs +++ b/src/Data/MIME/TransferEncoding.hs @@ -14,7 +14,6 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Data/MIME/Types.hs b/src/Data/MIME/Types.hs --- a/src/Data/MIME/Types.hs +++ b/src/Data/MIME/Types.hs @@ -14,8 +14,6 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE RankNTypes #-} - module Data.MIME.Types ( ContentTransferEncoding diff --git a/test-vectors/multipart-no-body.eml b/test-vectors/multipart-no-body.eml new file mode 100644 --- /dev/null +++ b/test-vectors/multipart-no-body.eml @@ -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-- diff --git a/tests/ContentTransferEncodings.hs b/tests/ContentTransferEncodings.hs --- a/tests/ContentTransferEncodings.hs +++ b/tests/ContentTransferEncodings.hs @@ -14,9 +14,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} module ContentTransferEncodings where diff --git a/tests/Generator.hs b/tests/Generator.hs --- a/tests/Generator.hs +++ b/tests/Generator.hs @@ -14,8 +14,9 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} module Generator where diff --git a/tests/Headers.hs b/tests/Headers.hs --- a/tests/Headers.hs +++ b/tests/Headers.hs @@ -14,8 +14,11 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# 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 " + , (Right (Mailbox (Just "John. (Doe)") (AddrSpec "jdoe" (DomainDotAtom $ "machine" :| ["example"]))) @=?) + , "\"John. (Doe)\" " ) ] 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 <> " ")) <$> + 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 diff --git a/tests/MIME.hs b/tests/MIME.hs --- a/tests/MIME.hs +++ b/tests/MIME.hs @@ -14,13 +14,14 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . +{-# 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" diff --git a/tests/Message.hs b/tests/Message.hs --- a/tests/Message.hs +++ b/tests/Message.hs @@ -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 diff --git a/tools/Parse.hs b/tools/Parse.hs --- a/tools/Parse.hs +++ b/tools/Parse.hs @@ -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