X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FEmailAddress.hs;h=8dca54b945695c238ff157ca95331668d2e8b992;hb=34f7ff7e07e3f3a0e53225b1efeeb6275c67c674;hp=88feafd59fb10f115578858e6a70f2fc9411d77b;hpb=d9cf306292f2bfaa00b4773737b67de7f4ecf983;p=email-validator.git diff --git a/src/EmailAddress.hs b/src/EmailAddress.hs index 88feafd..8dca54b 100644 --- a/src/EmailAddress.hs +++ b/src/EmailAddress.hs @@ -1,34 +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 Text.Email.Validate (isValid) -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 @@ -36,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 @@ -51,7 +89,7 @@ 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 [] @@ -59,6 +97,7 @@ validate_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) && @@ -67,10 +106,10 @@ validate_syntax rfc5322 address = else validate_regex address --- HUnit tests +-- * 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", @@ -80,9 +119,9 @@ good_addresses = bad_addresses :: [Address] bad_addresses = - map BSU.fromString [ --- Bad, but not caught by email-validate-1.0.0. --- "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", @@ -96,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", @@ -115,34 +154,31 @@ unsupported_addresses = "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." expected = True actual = all (validate_syntax False) good_addresses -test_good_addresses_rfc :: Test +test_good_addresses_rfc :: TestTree test_good_addresses_rfc = - testCase desc $ - assertEqual desc expected actual + testCase desc $ actual @?= expected where desc = "Good addresses are accepted with --rfc5322." expected = True actual = all (validate_syntax True) good_addresses -test_bad_addresses :: Test +test_bad_addresses :: TestTree test_bad_addresses = - testCase desc $ - assertEqual desc expected actual + 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 :: Test +test_bad_addresses_rfc :: TestTree test_bad_addresses_rfc = testCase desc $ assertEqual desc expected actual @@ -151,25 +187,23 @@ test_bad_addresses_rfc = expected = True 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." expected = True actual = all (not . (validate_syntax False)) unsupported_addresses -test_unsupported_addresses_rfc :: Test +test_unsupported_addresses_rfc :: TestTree test_unsupported_addresses_rfc = - testCase desc $ - assertEqual desc expected actual + 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,