module Main where
import Text.Email.Validate
import Test.HUnit
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Test.Framework as TF (defaultMain, testGroup, Test)
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.QuickCheck
main :: IO ()
main = defaultMain tests
tests :: [TF.Test]
tests = [
testGroup "EmailAddress Show/Read instances" [
testProperty "showLikeByteString" prop_showLikeByteString,
testProperty "showAndReadBackWithoutQuoteFails" prop_showAndReadBackWithoutQuoteFails,
testProperty "showAndReadBack" prop_showAndReadBack
],
testGroup "QuickCheck Text.Email.Validate" [
testProperty "doubleCanonicalize" prop_doubleCanonicalize
],
testGroup "Unit tests Text.Email.Validate" $ flip concatMap units
(\(em, valid, _) -> let email = BS.pack em
in
[
testCase ("doubleCanonicalize '" ++ em ++ "'") (True @=? case emailAddress email of { Nothing -> True; Just ok -> prop_doubleCanonicalize ok }),
testCase ("validity test '" ++ em ++ "'") (valid @=? isValid email)
]),
testGroup "Issues" [
testCase "#12" (let (Right em) = validate (BS.pack "\"\"@1") in em @=? read (show em))
]
]
instance Arbitrary ByteString where
arbitrary = fmap BS.pack arbitrary
instance Arbitrary EmailAddress where
arbitrary = do
local <- suchThat arbitrary (\x -> isEmail x (BS.pack "example.com"))
domain <- suchThat arbitrary (isEmail (BS.pack "example"))
let email = makeEmailLike local domain
let (Just result) = emailAddress email
return result
isEmail :: ByteString -> ByteString -> Bool
isEmail l d = isValid (makeEmailLike l d)
makeEmailLike :: ByteString -> ByteString -> ByteString
makeEmailLike l d = BS.concat [l, BS.singleton '@', d]
prop_doubleCanonicalize :: EmailAddress -> Bool
prop_doubleCanonicalize email = Just email == emailAddress (toByteString email)
prop_showLikeByteString :: EmailAddress -> Bool
prop_showLikeByteString email = show (toByteString email) == show email
prop_showAndReadBack :: EmailAddress -> Bool
prop_showAndReadBack email = read (show email) == email
readMaybe :: String -> Maybe EmailAddress
readMaybe s = case reads s of
[(x, "")] -> Just x
_ -> Nothing
prop_showAndReadBackWithoutQuoteFails :: EmailAddress -> Bool
prop_showAndReadBackWithoutQuoteFails email =
readMaybe (init s) == Nothing &&
readMaybe (tail s) == Nothing
where s = show email
--unitTest (x, y, z) = if not (isValid (BS.pack x) == y) then "" else (x ++" became "++ (case emailAddress (BS.pack x) of {Nothing -> "fail"; Just em -> show em}) ++": Should be "++show y ++", got "++show (not y)++"\n\t"++z++"\n")
units :: [(String, Bool, String)]
units = [
("first.last@example.com", True, ""),
("1234567890123456789012345678901234567890123456789012345678901234@example.com", True, ""),
("\"first last\"@example.com", True, ""),
("\"first\\\"last\"@example.com", True, ""),
("first\\@last@example.com", False, "Escaping can only happen within a quoted string"),
("\"first@last\"@example.com", True, ""),
("\"first\\\\last\"@example.com", True, ""),
("x@x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x234", True, ""),
("123456789012345678901234567890123456789012345678901234567890@12345678901234567890123456789012345678901234567890123456789.12345678901234567890123456789012345678901234567890123456789.123456789012345678901234567890123456789012345678901234567890123.example.com", True, ""),
("first.last@[12.34.56.78]", True, ""),
("first.last@[IPv6:::12.34.56.78]", True, ""),
("first.last@[IPv6:1111:2222:3333::4444:12.34.56.78]", True, ""),
("first.last@[IPv6:1111:2222:3333:4444:5555:6666:12.34.56.78]", True, ""),
("first.last@[IPv6:::1111:2222:3333:4444:5555:6666]", True, ""),
("first.last@[IPv6:1111:2222:3333::4444:5555:6666]", True, ""),
("first.last@[IPv6:1111:2222:3333:4444:5555:6666::]", True, ""),
("first.last@[IPv6:1111:2222:3333:4444:5555:6666:7777:8888]", True, ""),
("first.last@x23456789012345678901234567890123456789012345678901234567890123.example.com", True, ""),
("first.last@1xample.com", True, ""),
("first.last@123.example.com", True, ""),
("first.last", False, "No @"),
(".first.last@example.com", False, "Local part starts with a dot"),
("first.last.@example.com", False, "Local part ends with a dot"),
("first..last@example.com", False, "Local part has consecutive dots"),
("\"first\"last\"@example.com", False, "Local part contains unescaped excluded characters"),
("\"first\\last\"@example.com", True, "Any character can be escaped in a quoted string"),
("\"\"\"@example.com", False, "Local part contains unescaped excluded characters"),
("\"\\\"@example.com", False, "Local part cannot end with a backslash"),
("first\\\\@last@example.com", False, "Local part contains unescaped excluded characters"),
("first.last@", False, "No domain"),
("\"Abc\\@def\"@example.com", True, ""),
("\"Fred\\ Bloggs\"@example.com", True, ""),
("\"Joe.\\\\Blow\"@example.com", True, ""),
("\"Abc@def\"@example.com", True, ""),
("\"Fred Bloggs\"@example.com", True, ""),
("user+mailbox@example.com", True, ""),
("customer/department=shipping@example.com", True, ""),
("$A12345@example.com", True, ""),
("!def!xyz%abc@example.com", True, ""),
("_somename@example.com", True, ""),
("dclo@us.ibm.com", True, ""),
("abc\\@def@example.com", False, "This example from RFC3696 was corrected in an erratum"),
("abc\\\\@example.com", False, "This example from RFC3696 was corrected in an erratum"),
("peter.piper@example.com", True, ""),
("Doug\\ \\\"Ace\\\"\\ Lovell@example.com", False, "Escaping can only happen in a quoted string"),
("\"Doug \\\"Ace\\\" L.\"@example.com", True, ""),
("abc@def@example.com", False, "Doug Lovell says this should fail"),
("abc\\\\@def@example.com", False, "Doug Lovell says this should fail"),
("abc\\@example.com", False, "Doug Lovell says this should fail"),
("@example.com", False, "No local part"),
("doug@", False, "Doug Lovell says this should fail"),
("\"qu@example.com", False, "Doug Lovell says this should fail"),
("ote\"@example.com", False, "Doug Lovell says this should fail"),
(".dot@example.com", False, "Doug Lovell says this should fail"),
("dot.@example.com", False, "Doug Lovell says this should fail"),
("two..dot@example.com", False, "Doug Lovell says this should fail"),
("\"Doug \"Ace\" L.\"@example.com", False, "Doug Lovell says this should fail"),
("Doug\\ \\\"Ace\\\"\\ L\\.@example.com", False, "Doug Lovell says this should fail"),
("hello world@example.com", False, "Doug Lovell says this should fail"),
("gatsby@f.sc.ot.t.f.i.tzg.era.l.d.", False, "Doug Lovell says this should fail"),
("test@example.com", True, ""),
("TEST@example.com", True, ""),
("1234567890@example.com", True, ""),
("test+test@example.com", True, ""),
("test-test@example.com", True, ""),
("t*est@example.com", True, ""),
("+1~1+@example.com", True, ""),
("{_test_}@example.com", True, ""),
("\"[[ test ]]\"@example.com", True, ""),
("test.test@example.com", True, ""),
("\"test.test\"@example.com", True, ""),
("test.\"test\"@example.com", True, "Obsolete form, but documented in RFC2822"),
("\"test@test\"@example.com", True, ""),
("test@123.123.123.x123", True, ""),
("test@[123.123.123.123]", True, ""),
("test@example.example.com", True, ""),
("test@example.example.example.com", True, ""),
("test.example.com", False, ""),
("test.@example.com", False, ""),
("test..test@example.com", False, ""),
(".test@example.com", False, ""),
("test@test@example.com", False, ""),
("test@@example.com", False, ""),
("-- test --@example.com", False, "No spaces allowed in local part"),
("[test]@example.com", False, "Square brackets only allowed within quotes"),
("\"test\\test\"@example.com", True, "Any character can be escaped in a quoted string"),
("\"test\"test\"@example.com", False, "Quotes cannot be nested"),
("()[]\\;:,><@example.com", False, "Disallowed Characters"),
("test@.", False, "Dave Child says so"),
("test@example.", False, "Dave Child says so"),
("test@.org", False, "Dave Child says so"),
("test@[123.123.123.123", False, "Dave Child says so"),
("test@123.123.123.123]", False, "Dave Child says so"),
("NotAnEmail", False, "Phil Haack says so"),
("@NotAnEmail", False, "Phil Haack says so"),
("\"test\\\\blah\"@example.com", True, ""),
("\"test\\blah\"@example.com", True, "Any character can be escaped in a quoted string"),
("\"test\\\rblah\"@example.com", True, "Quoted string specifically excludes carriage returns unless escaped"),
("\"test\rblah\"@example.com", False, "Quoted string specifically excludes carriage returns"),
("\"test\\\"blah\"@example.com", True, ""),
("\"test\"blah\"@example.com", False, "Phil Haack says so"),
("customer/department@example.com", True, ""),
("_Yosemite.Sam@example.com", True, ""),
("~@example.com", True, ""),
(".wooly@example.com", False, "Phil Haack says so"),
("wo..oly@example.com", False, "Phil Haack says so"),
("pootietang.@example.com", False, "Phil Haack says so"),
(".@example.com", False, "Phil Haack says so"),
("\"Austin@Powers\"@example.com", True, ""),
("Ima.Fool@example.com", True, ""),
("\"Ima.Fool\"@example.com", True, ""),
("\"Ima Fool\"@example.com", True, ""),
("Ima Fool@example.com", False, "Phil Haack says so"),
("phil.h\\@\\@ck@haacked.com", False, "Escaping can only happen in a quoted string"),
("\"first\".\"last\"@example.com", True, ""),
("\"first\".middle.\"last\"@example.com", True, ""),
("\"first\\\\\"last\"@example.com", False, "Contains an unescaped quote"),
("\"first\".last@example.com", True, "obs-local-part form as described in RFC 2822"),
("first.\"last\"@example.com", True, "obs-local-part form as described in RFC 2822"),
("\"first\".\"middle\".\"last\"@example.com", True, "obs-local-part form as described in RFC 2822"),
("\"first.middle\".\"last\"@example.com", True, "obs-local-part form as described in RFC 2822"),
("\"first.middle.last\"@example.com", True, "obs-local-part form as described in RFC 2822"),
("\"first..last\"@example.com", True, "obs-local-part form as described in RFC 2822"),
("foo@[\\1.2.3.4]", False, "RFC 5321 specifies the syntax for address-literal and does not allow escaping"),
("\"first\\\\\\\"last\"@example.com", True, ""),
("first.\"mid\\dle\".\"last\"@example.com", True, "Backslash can escape anything but must escape something"),
("Test.\r\n Folding.\r\n Whitespace@example.com", True, ""),
("first\\last@example.com", False, "Unquoted string must be an atom"),
("Abc\\@def@example.com", False, "Was incorrectly given as a valid address in the original RFC3696"),
("Fred\\ Bloggs@example.com", False, "Was incorrectly given as a valid address in the original RFC3696"),
("Joe.\\\\Blow@example.com", False, "Was incorrectly given as a valid address in the original RFC3696"),
("\"test\\\r\n blah\"@example.com", False, "Folding white space can\'t appear within a quoted pair"),
("\"test\r\n blah\"@example.com", True, "This is a valid quoted string with folding white space"),
("{^c\\@**Dog^}@cartoon.com", False, "This is a throwaway example from Doug Lovell\'s article. Actually it\'s not a valid address."),
("(foo)cal(bar)@(baz)iamcal.com(quux)", True, "A valid address containing comments"),
("cal@iamcal(woo).(yay)com", True, "A valid address containing comments"),
("cal(woo(yay)hoopla)@iamcal.com", True, "A valid address containing comments"),
("cal(foo\\@bar)@iamcal.com", True, "A valid address containing comments"),
("cal(foo\\)bar)@iamcal.com", True, "A valid address containing comments and an escaped parenthesis"),
("cal(foo(bar)@iamcal.com", False, "Unclosed parenthesis in comment"),
("cal(foo)bar)@iamcal.com", False, "Too many closing parentheses"),
("cal(foo\\)@iamcal.com", False, "Backslash at end of comment has nothing to escape"),
("first().last@example.com", True, "A valid address containing an empty comment"),
("first.(\r\n middle\r\n )last@example.com", True, "Comment with folding white space"),
("first(12345678901234567890123456789012345678901234567890)last@(1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890)example.com", False, "Too long with comments, not too long without"),
("first(Welcome to\r\n the (\"wonderful\" (!)) world\r\n of email)@example.com", True, "Silly example from my blog post"),
("pete(his account)@silly.test(his host)", True, "Canonical example from RFC5322"),
("c@(Chris\'s host.)public.example", True, "Canonical example from RFC5322"),
("jdoe@machine(comment). example", True, "Canonical example from RFC5322"),
("1234 @ local(blah) .machine .example", True, "Canonical example from RFC5322"),
("first(middle)last@example.com", False, "Can\'t have a comment or white space except at an element boundary"),
("first(abc.def).last@example.com", True, "Comment can contain a dot"),
("first(a\"bc.def).last@example.com", True, "Comment can contain double quote"),
("first.(\")middle.last(\")@example.com", True, "Comment can contain a quote"),
("first(abc(\"def\".ghi).mno)middle(abc(\"def\".ghi).mno).last@(abc(\"def\".ghi).mno)example(abc(\"def\".ghi).mno).(abc(\"def\".ghi).mno)com(abc(\"def\".ghi).mno)", False, "Can\'t have comments or white space except at an element boundary"),
("first(abc\\(def)@example.com", True, "Comment can contain quoted-pair"),
("first.last@x(1234567890123456789012345678901234567890123456789012345678901234567890).com", True, "Label is longer than 63 octets, but not with comment removed"),
("a(a(b(c)d(e(f))g)h(i)j)@example.com", True, ""),
("a(a(b(c)d(e(f))g)(h(i)j)@example.com", False, "Braces are not properly matched"),
("name.lastname@domain.com", True, ""),
(".@", False, ""),
("@bar.com", False, ""),
("@@bar.com", False, ""),
("a@bar.com", True, ""),
("aaa.com", False, ""),
("aaa@.com", False, ""),
("aaa@.123", False, ""),
("aaa@[123.123.123.123]", True, ""),
("aaa@[123.123.123.123]a", False, "extra data outside ip"),
("a@bar.com.", False, ""),
("a-b@bar.com", True, ""),
("+@b.c", True, "TLDs can be any length"),
("+@b.com", True, ""),
("-@..com", False, ""),
("-@a..com", False, ""),
("a@b.co-foo.uk", True, ""),
("\"hello my name is\"@stutter.com", True, ""),
("\"Test \\\"Fail\\\" Ing\"@example.com", True, ""),
("valid@special.museum", True, ""),
("shaitan@my-domain.thisisminekthx", True, "Disagree with Paul Gregg here"),
("test@...........com", False, "......"),
("\"Joe\\\\Blow\"@example.com", True, ""),
("Invalid \\\n Folding \\\n Whitespace@example.com", False, "This isn\'t FWS so Dominic Sayers says it\'s invalid"),
("HM2Kinsists@(that comments are allowed)this.is.ok", True, ""),
("user%uucp!path@somehost.edu", True, ""),
("\"first(last)\"@example.com", True, ""),
(" \r\n (\r\n x \r\n ) \r\n first\r\n ( \r\n x\r\n ) \r\n .\r\n ( \r\n x) \r\n last \r\n ( x \r\n ) \r\n @example.com", True, ""),
("test.\r\n \r\n obs@syntax.com", True, "obs-fws allows multiple lines"),
("test. \r\n \r\n obs@syntax.com", True, "obs-fws allows multiple lines (test 2: space before break)"),
("test.\r\n\r\n obs@syntax.com", False, "obs-fws must have at least one WSP per line"),
("\"null \\\0\"@char.com", True, "can have escaped null character"),
("\"null \0\"@char.com", False, "cannot have unescaped null character")
-- items below here are invalid according to other RFCs (or opinions)
--("\"\"@example.com", False, "Local part is effectively empty"),
--("foobar@192.168.0.1", False, "ip need to be []"),
--("first.last@[.12.34.56.78]", False, "Only char that can precede IPv4 address is \':\'"),
--("first.last@[12.34.56.789]", False, "Can\'t be interpreted as IPv4 so IPv6 tag is missing"),
--("first.last@[::12.34.56.78]", False, "IPv6 tag is missing"),
--("first.last@[IPv5:::12.34.56.78]", False, "IPv6 tag is wrong"),
--("first.last@[IPv6:1111:2222:3333::4444:5555:12.34.56.78]", False, "Too many IPv6 groups (4 max)"),
--("first.last@[IPv6:1111:2222:3333:4444:5555:12.34.56.78]", False, "Not enough IPv6 groups"),
--("first.last@[IPv6:1111:2222:3333:4444:5555:6666:7777:12.34.56.78]", False, "Too many IPv6 groups (6 max)"),
--("first.last@[IPv6:1111:2222:3333:4444:5555:6666:7777]", False, "Not enough IPv6 groups"),
--("first.last@[IPv6:1111:2222:3333:4444:5555:6666:7777:8888:9999]", False, "Too many IPv6 groups (8 max)"),
--("first.last@[IPv6:1111:2222::3333::4444:5555:6666]", False, "Too many \'::\' (can be none or one)"),
--("first.last@[IPv6:1111:2222:3333::4444:5555:6666:7777]", False, "Too many IPv6 groups (6 max)"),
--("first.last@[IPv6:1111:2222:333x::4444:5555]", False, "x is not valid in an IPv6 address"),
--("first.last@[IPv6:1111:2222:33333::4444:5555]", False, "33333 is not a valid group in an IPv6 address"),
--("first.last@example.123", False, "TLD can\'t be all digits"),
--("aaa@[123.123.123.333]", False, "not a valid IP"),
--("first.last@[IPv6:1111:2222:3333:4444:5555:6666:12.34.567.89]", False, "IPv4 part contains an invalid octet"),
--("a@b", False, ""),
--("a@bar", False, ""),
--("invalid@special.museum-", False, ""),
--("a@-b.com", False, ""),
--("a@b-.com", False, ""),
--("\"foo\"(yay)@(hoopla)[1.2.3.4]", False, "Address literal can\'t be commented (RFC5321)"),
--("first.\"\".last@example.com", False, "Contains a zero-length element"),
--("test@example", False, "Dave Child says so"),
--("12345678901234567890123456789012345678901234567890123456789012345@example.com", False, "Local part more than 64 characters"),
--("x@x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456", False, "Domain exceeds 255 chars"),
--("test@123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012.com", False, "255 characters is maximum length for domain. This is 256."),
--("123456789012345678901234567890123456789012345678901234567890@12345678901234567890123456789012345678901234567890123456789.12345678901234567890123456789012345678901234567890123456789.12345678901234567890123456789012345678901234567890123456789.1234.example.com", False, "Entire address is longer than 256 characters"),
--("test@123.123.123.123", False, "Top Level Domain won\'t be all-numeric (see RFC3696 Section 2). I disagree with Dave Child on this one."),
--("first.last@x234567890123456789012345678901234567890123456789012345678901234.example.com", False, "Label can\'t be longer than 63 octets"),
--("first.last@com", False, "Mail host must be second- or lower level"),
--("first.last@-xample.com", False, "Label can\'t begin with a hyphen"),
--("first.last@exampl-.com", False, "Label can\'t end with a hyphen"),
]