purebred-email 0.4.1 → 0.4.2

raw patch · 4 files changed

+75/−66 lines, 4 filesdep ~semigroupsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: semigroups

API changes (from Hackage documentation)

Files

• purebred-email.cabal +2/−2
• src/Data/RFC5322.hs +47/−48
• tests/Headers.hs +21/−15
• tests/Message.hs +5/−1

@@ -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

@@ -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

@@ -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)

@@ -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