V3

.gitmodules

@@ -0,0 +1,3 @@
+[submodule "testdata/isemail"]
+	path = testdata/isemail
+	url = https://github.com/dominicsayers/isemail

email-validate.cabal

@@ -44,9 +44,11 @@ test-suite Main
     build-depends:
         email-validate,
         base >= 4 && < 5,
+        bytestring >= 0.9,
+        file-embed,
         hspec,
         QuickCheck >= 2.4 && < 2.11,
-        bytestring >= 0.9
+        xml
 
 test-suite doctests
     type: exitcode-stdio-1.0

src/Text/Email/Parser.hs

@@ -1,4 +1,6 @@
-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Text.Email.Parser
     ( addrSpec
@@ -122,9 +124,11 @@ isDomainText x = inClass "\33-\90\94-\126" x || isObsNoWsCtl x
 
 quotedString :: Parser ByteString
 quotedString =
-    (BS.cons '"' . flip BS.snoc '"' . BS.concat) <$>
-        between1 (char '"')
-            (many (optional fws >> quotedContent) <* optional fws)
+    between1 (char '"') (do
+        quotedParts <- many (mappend <$> option mempty fws' <*> quotedContent)
+        endWS <- option mempty fws'
+
+        return (mconcat ("\"" : quotedParts ++ [endWS, "\""])))
 
 quotedContent :: Parser ByteString
 quotedContent = takeWhile1 isQuotedText <|> quotedPair
@@ -141,6 +145,18 @@ cfws = skipMany (comment <|> fws)
 fws :: Parser ()
 fws = void (wsp1 >> optional (crlf >> wsp1)) <|> (skipMany1 (crlf >> wsp1))
 
+-- | Folding whitespace, where it is significant (i.e. inside a quoted-string)
+fws' :: Parser ByteString
+fws' = do
+    (ws, ()) <- match fws
+    return (BS.pack (stripCRLF (BS.unpack ws)))
+
+    where 
+    stripCRLF ('\r' : '\n' : xs) = stripCRLF xs
+    stripCRLF (x : xs) = x : stripCRLF xs
+    stripCRLF [] = []
+
+
 between :: Applicative f => f l -> f r -> f a -> f a
 between l r x = l *> x <* r
 

tests/Main.hs

@@ -1,20 +1,25 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Main where
 
 import Control.Exception (evaluate)
 import Control.Monad (forM_)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BS
+import Data.FileEmbed (embedFile, makeRelativeToProject)
+import Data.Function ((&))
 import Data.List (isInfixOf)
 import Data.Maybe (Maybe(..), isNothing, fromJust)
 import Data.Monoid ((<>))
 
 import Test.Hspec (hspec, context, describe, errorCall, it, parallel, shouldBe, shouldSatisfy)
 import Test.QuickCheck (Arbitrary(..), suchThat, property)
 
+import qualified Text.XML.Light as X
+
 import Text.Email.QuasiQuotation (email)
 import Text.Email.Validate
     ( EmailAddress
@@ -28,15 +33,21 @@ import Text.Email.Validate
     , unsafeEmailAddress
     )
 
-main :: IO ()
-main = hspec $ parallel $ do
+testXml :: ByteString
+testXml = $(makeRelativeToProject "testdata/isemail/test/tests.xml" >>= embedFile)
 
-    showAndRead
-    canonicalization
-    exampleTests
-    specificFailures
-    simpleAccessors
-    quasiQuotationTests
+main :: IO ()
+main =
+
+    hspec $ parallel $ do
+        showAndRead
+        canonicalization
+        exampleTests
+        testsFromXml
+        specificFailures
+        simpleAccessors
+        quasiQuotationTests
+        testsFromXml
 
 canonicalization =
     describe "emailAddress" $ do
@@ -65,6 +76,40 @@ exampleTests =
                                 errMessage `shouldSatisfy` (err `isInfixOf`)
                         (_, _) -> return ()
 
+testsFromXml = do
+    let tests = X.onlyElems (X.parseXML testXml) >>= X.findElements (name "test")
+    forM_ tests $ \test -> do
+
+        let id = X.findAttr (name "id") test & fromJust
+
+        let child s = X.findChild (name s) test & fromJust & X.strContent
+
+        let address = child "address"
+        let category = child "category"
+        let diagnosis = child "diagnosis"
+
+        describe ("Test " ++ id ++ ": " ++ show address) $ do
+
+            if (category == "ISEMAIL_ERR"
+                || diagnosis == "ISEMAIL_RFC5322_TOOLONG"
+                || diagnosis == "ISEMAIL_RFC5322_DOMAIN_TOOLONG"
+                || diagnosis == "ISEMAIL_RFC5322_LABEL_TOOLONG"
+                || diagnosis == "ISEMAIL_RFC5322_LOCAL_TOOLONG"
+                || diagnosis == "ISEMAIL_RFC5322_DOMLIT_OBSDTEXT"
+                || diagnosis == "ISEMAIL_RFC5322_DOMAIN")
+                && id /= "35" -- disagree about this example!
+            then
+                it "should be invalid" $
+                    isValid (BS.pack address) `shouldBe` False
+
+            else
+                it "should be valid" $
+                    isValid (BS.pack address) `shouldBe` True
+
+
+    where
+    name s = X.QName s Nothing Nothing
+
 showAndRead =
     describe "show/read instances" $ do
 
@@ -155,7 +200,6 @@ why ex str = ex { exampleWhy = str }
 errorShouldContain :: Example -> String -> Example
 errorShouldContain ex str = ex { errorContains = Just str }
 
-
 examples :: [Example]
 examples =
     let domain249 = BS.intercalate "." (take 25 (repeat (BS.replicate 9 'x'))) in