diff --git a/purebred-email.cabal b/purebred-email.cabal --- a/purebred-email.cabal +++ b/purebred-email.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: purebred-email -version: 0.4.1 +version: 0.4.2 synopsis: types and parser for email messages (including MIME) description: The purebred email library. RFC 5322, MIME, etc. @@ -74,7 +74,7 @@ , deepseq >= 1.4.2 , lens >= 4 && < 5 , semigroupoids >= 5 && < 6 - , semigroups >= 0.16 && < 0.19 + , semigroups >= 0.16 , stringsearch >= 0.3 , text >= 1.2 , time diff --git a/src/Data/RFC5322.hs b/src/Data/RFC5322.hs --- a/src/Data/RFC5322.hs +++ b/src/Data/RFC5322.hs @@ -270,42 +270,40 @@ buildPhrase s = case enc s of PhraseAtom -> T.encodeUtf8Builder s - PhraseQuotedString _ -> "\"" <> T.encodeUtf8BuilderEscaped escPrim s <> "\"" + PhraseQuotedString -> qsBuilder False + PhraseQuotedStringEscapeSpace -> qsBuilder True PhraseEncodedWord -> buildEncodedWord . transferEncode . charsetEncode $ s where - enc = T.foldr (\c z -> encChar c <> z) mempty - encChar c + enc = snd . T.foldr (\c (prev, req) -> (c, encChar prev c <> req)) ('\0', mempty) + encChar prev c | isAtext c = PhraseAtom - | isQtext c = PhraseQuotedString 0 - | isVchar c || c == ' ' = PhraseQuotedString 1 + | isQtext c = PhraseQuotedString + | isVchar c = PhraseQuotedString + | c == ' ' = + if prev == ' ' -- two spaces in a row; need to avoid FWS + then PhraseQuotedStringEscapeSpace + else PhraseQuotedString | otherwise = PhraseEncodedWord - -- FIXME: this probably doesn't handle consecutive SPACE properly - -- due to FWS: - -- - -- quoted-string = [CFWS] - -- DQUOTE *([FWS] qcontent) [FWS] DQUOTE - -- [CFWS] - -- - -- Do not be surprised if the roundtrip property fails - -- - escPrim = Prim.condB (\c -> isQtext c || c == 32) + qsBuilder escSpace = "\"" <> T.encodeUtf8BuilderEscaped (escPrim escSpace) s <> "\"" + escPrim escSpace = Prim.condB (\c -> isQtext c || not escSpace && c == 32) (Prim.liftFixedToBounded Prim.word8) (Prim.liftFixedToBounded $ (fromChar '\\',) Prim.>$< Prim.word8 Prim.>*< Prim.word8) -- | Data type used to compute escaping requirement of a Text 'phrase' --- 'PhraseQuotedString' records the number of additional characters --- needed for escapes (backslash). It does not include the surrounding --- DQUOTE characters. -- -data PhraseEscapeRequirement = PhraseAtom | PhraseQuotedString Int | PhraseEncodedWord +data PhraseEscapeRequirement + = PhraseAtom + | PhraseQuotedString + | PhraseQuotedStringEscapeSpace + | PhraseEncodedWord + deriving (Eq, Ord) instance Semigroup PhraseEscapeRequirement where - PhraseEncodedWord <> _ = PhraseEncodedWord - PhraseAtom <> a = a - PhraseQuotedString n <> PhraseQuotedString m = PhraseQuotedString (n + m) - a <> PhraseAtom = a - _ <> PhraseEncodedWord = PhraseEncodedWord + PhraseEncodedWord <> _ = + -- allows early termination of folds + PhraseEncodedWord + l <> r = max l r instance Monoid PhraseEscapeRequirement where mempty = PhraseAtom @@ -446,35 +444,36 @@ let key = original k in Builder.byteString key - <> ": " - <> Builder.byteString (foldUnstructured (B.length key) v) + <> ":" + <> foldUnstructured v (B.length key + 1) <> "\r\n" - -- | Render a field body with proper folding -- --- Algorithm: --- * Break the string on white space --- * Use a counter which indicates a new folding line if it exceeds 77 characters --- * Whenever we create a new line, concatenate all words back with white space and push it into the result --- * The result is a list of byte strings, which is concatenated with \r\n\s --- --- Notes: --- * First take at this, so possibly very inefficient --- * No other delimiters (e.g. commas, full stops, etc) are considered for --- folding other than whitespace --- * Attaches an additional whitespace when joining +-- Folds on whitespace (and only whitespace). Sequential whitespace +-- chars are folded. That's OK because the grammar says it is +-- folding whitespace. -- -foldUnstructured :: Int -> B.ByteString -> B.ByteString -foldUnstructured i b = - let xs = chunk (i + 2) (Char8.words b) [] [] - in B.intercalate "\r\n " (filter (not . B.null) xs) - -chunk :: Int -> [B.ByteString] -> [B.ByteString] -> [B.ByteString] -> [B.ByteString] -chunk _ [] xs result = result <> [Char8.unwords xs] -chunk max' (x:rest) xs result = if (max' + B.length x + 1) >= 77 - then result <> [Char8.unwords xs] <> chunk (B.length x + 1) rest [x] [] - else result <> chunk (max' + B.length x + 1) rest (xs <> [x]) result +foldUnstructured :: B.ByteString -> Int -> Builder.Builder +foldUnstructured s i = case Char8.words s of + [] -> mempty + (h:t) -> + -- Special case to prevent wrapping of first word; + -- see 6dbc04fb1863e845699b1cef50f4edaf1326bdae for info. + " " <> Builder.byteString h <> go t (i + 1 + B.length h) + where + limit = 76 -- could be 78, but this preserves old behaviour + go [] _ = mempty + go (chunk:chunks) col + | col + 1 + B.length chunk < limit = + -- there is room for the chunk + " " <> Builder.byteString chunk <> go chunks (col + 1 + B.length chunk) + | col <= 1 = + -- there isn't room for the chunk, but we are at the + -- beginning of the line so add it here anyway (otherwise + -- we will add "\r\n" and recurse forever + " " <> Builder.byteString chunk <> "\r\n" <> go chunks 0 + | otherwise = "\r\n" <> go (chunk:chunks) 0 -- fold -- | Printable ASCII excl. ':' isFtext :: Word8 -> Bool diff --git a/tests/Headers.hs b/tests/Headers.hs --- a/tests/Headers.hs +++ b/tests/Headers.hs @@ -8,16 +8,16 @@ import Data.Semigroup ((<>)) import Data.Word (Word8) -import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString as B -import Data.ByteString.Lazy (toStrict) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Attoparsec.ByteString.Char8 (parseOnly) import qualified Data.Attoparsec.Text as AText (parseOnly) import qualified Data.ByteString.Builder as Builder import qualified Data.CaseInsensitive as CI import Data.Either (isLeft) -import Test.Tasty (TestTree, testGroup) +import Test.Tasty import Test.Tasty.HUnit (assertBool, (@=?), (@?=), testCase, Assertion) import Test.Tasty.QuickCheck import Test.QuickCheck.Instances () @@ -26,8 +26,8 @@ import qualified Data.RFC5322.Address.Text as AddressText (mailbox, address, renderAddress) -renderField :: (CI.CI B.ByteString, B.ByteString) -> B.ByteString -renderField = toStrict . Builder.toLazyByteString . buildField +renderField :: (CI.CI B.ByteString, B.ByteString) -> L.ByteString +renderField = Builder.toLazyByteString . buildField unittests :: TestTree unittests = testGroup "Headers" @@ -345,15 +345,21 @@ genField :: Gen (CI.CI B.ByteString, B.ByteString) genField = (,) <$> (CI.mk <$> genFieldItem) <*> genFieldBody -newtype MailHeaders = MailHeaders { unHeader :: (CI.CI B.ByteString, B.ByteString)} - deriving (Show) - -instance Arbitrary MailHeaders where - arbitrary = MailHeaders <$> genField +prop_renderHeadersRoundtrip :: Property +prop_renderHeadersRoundtrip = forAll genField $ \kv -> + parse field (renderField kv) == Right kv -prop_renderHeadersRoundtrip :: MailHeaders -> Bool -prop_renderHeadersRoundtrip h = parse field (renderField (unHeader h)) == Right (unHeader h) +prop_foldedUnstructuredLimited :: Property +prop_foldedUnstructuredLimited = forAll genField $ \kv -> + all ((<= 78) . L.length) (crlfLines $ renderField kv) -prop_foldedUnstructuredLimited :: MailHeaders -> Bool -prop_foldedUnstructuredLimited h = let xs = BC.lines $ renderField (unHeader h) - in all (== True) ((\x -> B.length x <= 78) <$> xs) +crlfLines :: L.ByteString -> [L.ByteString] +crlfLines = go "" + where + go acc s = + let (h,t) = L8.span (/= '\r') s + in + case L.take 2 t of + "" -> [acc <> h] + "\r\n" -> acc <> h : go "" (L.drop 2 t) + _ -> go (acc <> h <> L.take 1 t) (L.drop 1 t) diff --git a/tests/Message.hs b/tests/Message.hs --- a/tests/Message.hs +++ b/tests/Message.hs @@ -27,7 +27,7 @@ import Data.Char (isPrint) import Data.Foldable (fold) -import Data.List.NonEmpty (NonEmpty, intersperse) +import Data.List.NonEmpty (NonEmpty(..), intersperse) import Control.Lens (set, view) import qualified Data.ByteString as B @@ -47,6 +47,10 @@ [ testProperty "message round trip" prop_messageRoundTrip , localOption (HedgehogTestLimit (Just 10000)) $ testProperty "message round trip with From header" prop_messageFromRoundTrip + , testProperty "mailbox with consecutive spaces" $ + -- https://github.com/purebred-mua/purebred-email/issues/56 + let m = Mailbox (Just " ") (AddrSpec "!" (DomainDotAtom ("!" :| []))) + in withTests 1 . property . assert $ renderMailbox m == "\"\\ \\ \" " ] printableAsciiChar, printableUnicodeChar, unicodeCharAsciiBias :: Gen Char