X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FEmailAddress.hs;h=436d3f5c0e83dbd513fc0aa53f5186ab96e4e9f9;hb=eae92cebe7fab4afc5c7de377ec30ec348ef09ad;hp=c20aa3069324fc7e0eab6d2857c54729b0c47bec;hpb=a5e228280dfbdbd8f2b1f271adb362fee1a43de4;p=email-validator.git

diff --git a/src/EmailAddress.hs b/src/EmailAddress.hs
index c20aa30..436d3f5 100644
--- a/src/EmailAddress.hs
+++ b/src/EmailAddress.hs
@@ -1,8 +1,14 @@
 module EmailAddress
 where
 
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.UTF8 as BSU
+import qualified Data.ByteString.Char8 as BS (
+  ByteString,
+  break,
+  empty,
+  length,
+  pack,
+  tail)
+import Text.Email.Validate (isValid)
 import Test.HUnit (assertEqual)
 import Test.Framework (Test, testGroup)
 import Test.Framework.Providers.HUnit (testCase)
@@ -15,9 +21,9 @@ import Text.Regex.PCRE.Light (
   utf8
   )
 
-type Address = BSU.ByteString
-type LocalPart = BSU.ByteString
-type DomainPart = BSU.ByteString
+type Address = BS.ByteString
+type LocalPart = BS.ByteString
+type DomainPart = BS.ByteString
 
 
 
@@ -27,14 +33,17 @@ parts address =
   (before, after)
   where
     break_func = (== '@')
-    (before, rest) = BSU.break break_func address
-    after = BS.tail rest
+    (before, rest) = BS.break break_func address
+    after =
+      if rest == BS.empty
+      then BS.empty
+      else BS.tail rest
 
 
 -- | Check that the lengths of the local/domain parts are within spec.
 validate_length :: Address -> Bool
 validate_length address =
-  (BSU.length localpart <= 64) && (BSU.length domain <= 255)
+  (BS.length localpart <= 64) && (BS.length domain <= 255)
   where
     (localpart, domain) = parts address
 
@@ -47,16 +56,26 @@ validate_regex address =
     _       -> True
   where
     regex_str = "(\\w+)([\\w\\-\\.]*)@(([a-z0-9\\-]+\\.)+)[a-z]{2,4}$"
-    regex_bs  = BSU.fromString regex_str
+    regex_bs  = BS.pack regex_str
     regex = compile regex_bs [anchored, caseless, dollar_endonly, utf8]
     matches = match regex address []
 
 
+-- | Validate the syntax of an email address by checking its length
+--   and validating it against either a simple regex or RFC5322,
+--   depending on the --rfc5322 flag.
+validate_syntax :: Bool -> Address -> Bool
+validate_syntax rfc5322 address =
+  (validate_length address) &&
+    if rfc5322
+    then isValid address
+    else validate_regex address
+
 
 -- HUnit tests
 good_addresses :: [Address]
 good_addresses =
-  map BSU.fromString [
+  map BS.pack [
     "phil@hotmail.com",
     "philq23562@hotmail.com",
     "gsdfg22-2_22@hot-mail.com",
@@ -66,17 +85,23 @@ good_addresses =
 
 bad_addresses :: [Address]
 bad_addresses =
-  map BSU.fromString [
-    "bad%char@domain.com",
-    "bad^char@domain.com",
-    "badunderscore@dom_ain.com",
+  map BS.pack [
+    -- Bad, but not caught by email-validate-0.0.1.
+    --  "badunderscore@dom_ain.com",
     "(fail)@domain.com",
     "no spaces@domain.com",
-    ".beginswith@a-dot.com"  ]
+    ".beginswith@a-dot.com",
+    "a",
+    "a.com",
+    "@b.com",
+    "b@",
+    (replicate 65 'a') ++ "@" ++ "domain.com",
+    "abcdefg@" ++ (replicate 253 'a') ++ ".com",
+    (replicate 100 'a') ++ "@" ++ (replicate 300 'a') ++ ".com" ]
 
 unsupported_addresses :: [Address]
 unsupported_addresses =
-  map BSU.fromString [
+  map BS.pack [
     "ok!char@domain.com",
     "ok#char@domain.com",
     "ok$char@domain.com",
@@ -91,7 +116,9 @@ unsupported_addresses =
     "ok|char@domain.com",
     "ok}char@domain.com",
     "ok~char@domain.com",
-    "tom.phillips@[127.0.0.1]" ]
+    "tom.phillips@[127.0.0.1]",
+    "bad%char@domain.com",
+    "bad^char@domain.com" ]
 
 test_good_addresses :: Test
 test_good_addresses =
@@ -100,7 +127,16 @@ test_good_addresses =
   where
     desc = "Good addresses are accepted."
     expected = True
-    actual = and (map validate_regex good_addresses)
+    actual = all (validate_syntax False) good_addresses
+
+test_good_addresses_rfc :: Test
+test_good_addresses_rfc =
+  testCase desc $
+    assertEqual desc expected actual
+  where
+    desc = "Good addresses are accepted with --rfc5322."
+    expected = True
+    actual = all (validate_syntax True) good_addresses
 
 test_bad_addresses :: Test
 test_bad_addresses =
@@ -109,7 +145,16 @@ test_bad_addresses =
   where
     desc = "Bad addresses are not accepted."
     expected = True
-    actual = and (map (not . validate_regex) bad_addresses)
+    actual = all (not . (validate_syntax False)) bad_addresses
+
+test_bad_addresses_rfc :: Test
+test_bad_addresses_rfc =
+  testCase desc $
+    assertEqual desc expected actual
+  where
+    desc = "Bad addresses are not accepted with --rfc5322."
+    expected = True
+    actual = all (not . (validate_syntax True)) bad_addresses
 
 test_unsupported_addresses :: Test
 test_unsupported_addresses =
@@ -118,12 +163,23 @@ test_unsupported_addresses =
   where
     desc = "Unsupported addresses are not accepted."
     expected = True
-    actual = and (map (not . validate_regex) unsupported_addresses)
+    actual = all (not . (validate_syntax False)) unsupported_addresses
 
+test_unsupported_addresses_rfc :: Test
+test_unsupported_addresses_rfc =
+  testCase desc $
+    assertEqual desc expected actual
+  where
+    desc = "Unsupported addresses are accepted with --rfc5322."
+    expected = True
+    actual = all (validate_syntax True) unsupported_addresses
 
 email_address_tests :: Test
 email_address_tests =
   testGroup "EmailAddress Tests" [
     test_good_addresses,
+    test_good_addresses_rfc,
     test_bad_addresses,
-    test_unsupported_addresses ]
+    test_bad_addresses_rfc,
+    test_unsupported_addresses,
+    test_unsupported_addresses_rfc ]