X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FEmailAddress.hs;h=f56813231adf99bc2534cd37b3aed848cb52580c;hb=HEAD;hp=615d43cf5ae02358de0ff5b47c9ab2b4e705e33f;hpb=80e83309f0de0b4b89002564c94d9d988924bf9e;p=email-validator.git diff --git a/src/EmailAddress.hs b/src/EmailAddress.hs index 615d43c..f568132 100644 --- a/src/EmailAddress.hs +++ b/src/EmailAddress.hs @@ -1,33 +1,50 @@ -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 @@ -35,14 +52,36 @@ parts address = -- | 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 @@ -50,22 +89,27 @@ 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 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", @@ -75,10 +119,9 @@ 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", @@ -92,7 +135,7 @@ bad_addresses = unsupported_addresses :: [Address] unsupported_addresses = - map BSU.fromString [ + map BS.pack [ "ok!char@domain.com", "ok#char@domain.com", "ok$char@domain.com", @@ -107,39 +150,65 @@ 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 :: 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 = and (map 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 = and (map (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 = and (map (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 ]