-module EmailAddress
+module EmailAddress (
+ Address,
+ parts,
+ validate_syntax,
+ -- * Test exports
+ email_address_tests )
where
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.UTF8 as BSU
-import Test.HUnit (assertEqual)
-import Test.Framework (Test, testGroup)
-import Test.Framework.Providers.HUnit (testCase)
+import qualified Data.ByteString.Char8 as BS (
+ ByteString,
+ break,
+ empty,
+ length,
+ pack,
+ tail )
+import Text.Email.Validate ( isValid )
+import Test.HUnit ( assertEqual )
+import Test.Tasty ( TestTree, testGroup )
+import Test.Tasty.HUnit ( (@?=), testCase )
import Text.Regex.PCRE.Light (
anchored,
caseless,
compile,
dollar_endonly,
match,
- utf8
- )
+ 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
-- | Split an address into local/domain parts.
+--
+-- Examples:
+--
+-- >>> let addr = BS.pack "user@example.com"
+-- >>> parts addr
+-- ("user","example.com")
+--
parts :: Address -> (LocalPart, DomainPart)
parts address =
(before, after)
where
break_func = (== '@')
- (before, rest) = BSU.break break_func address
+ (before, rest) = BS.break break_func address
after =
if rest == BS.empty
then BS.empty
-- | Check that the lengths of the local/domain parts are within spec.
+--
+-- Examples:
+--
+-- >>> let jr = (replicate 64 'a') ++ "@" ++ (replicate 255 'x')
+-- >>> let just_right = BS.pack jr
+-- >>> validate_length just_right
+-- True
+-- >>> let too_long = BS.pack (jr ++ "x")
+-- >>> validate_length too_long
+-- False
+--
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
+
-- | Validate an email address against a simple regex. This should
-- catch common addresses but disallows a lot of (legal) weird stuff.
+--
+-- Examples:
+--
+-- >>> let addr = BS.pack "user@example.com"
+-- >>> validate_regex addr
+-- True
+-- >>> let bad_addr = BS.pack "user@[]example.com"
+-- >>> validate_regex bad_addr
+-- False
+--
validate_regex :: Address -> Bool
validate_regex address =
case matches of
_ -> 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 a simple regex.
-validate_syntax :: Address -> Bool
-validate_syntax address =
- (validate_length address) && (validate_regex address)
-
-
--- HUnit tests
+-- 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
+
+
+-- * Tasty Tests
good_addresses :: [Address]
good_addresses =
- map BSU.fromString [
+ map BS.pack [
"phil@hotmail.com",
"philq23562@hotmail.com",
"gsdfg22-2_22@hot-mail.com",
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",
unsupported_addresses :: [Address]
unsupported_addresses =
- map BSU.fromString [
+ map BS.pack [
"ok!char@domain.com",
"ok#char@domain.com",
"ok$char@domain.com",
"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 :: TestTree
test_good_addresses =
- testCase desc $
- assertEqual desc expected actual
+ testCase desc $ actual @?= expected
where
- desc = "Good addresses are accepted."
+ desc = "Good addresses are accepted"
expected = True
- actual = all validate_syntax good_addresses
+ actual = all (validate_syntax False) good_addresses
-test_bad_addresses :: Test
+test_good_addresses_rfc :: TestTree
+test_good_addresses_rfc =
+ testCase desc $ actual @?= expected
+ where
+ desc = "Good addresses are accepted with --rfc5322"
+ expected = True
+ actual = all (validate_syntax True) good_addresses
+
+test_bad_addresses :: TestTree
test_bad_addresses =
+ testCase desc $ actual @?= expected
+ where
+ desc = "Bad addresses are not accepted"
+ expected = True
+ actual = all (not . (validate_syntax False)) bad_addresses
+
+test_bad_addresses_rfc :: TestTree
+test_bad_addresses_rfc =
testCase desc $
assertEqual desc expected actual
where
- desc = "Bad addresses are not accepted."
+ desc = "Bad addresses are not accepted with --rfc5322"
expected = True
- actual = all (not . validate_syntax) bad_addresses
+ actual = all (not . (validate_syntax True)) bad_addresses
-test_unsupported_addresses :: Test
+test_unsupported_addresses :: TestTree
test_unsupported_addresses =
- testCase desc $
- assertEqual desc expected actual
+ testCase desc $ actual @?= expected
where
- desc = "Unsupported addresses are not accepted."
+ desc = "Unsupported addresses are not accepted"
expected = True
- actual = all (not . validate_syntax) unsupported_addresses
+ actual = all (not . (validate_syntax False)) unsupported_addresses
+test_unsupported_addresses_rfc :: TestTree
+test_unsupported_addresses_rfc =
+ testCase desc $ actual @?= expected
+ where
+ desc = "Unsupported addresses are accepted with --rfc5322"
+ expected = True
+ actual = all (validate_syntax True) unsupported_addresses
-email_address_tests :: Test
+email_address_tests :: TestTree
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 ]
projects / email-validator.git / blobdiff