4 import qualified Data.ByteString as BS
5 import qualified Data.ByteString.UTF8 as BSU
6 import Test.HUnit (assertEqual)
7 import Test.Framework (Test, testGroup)
8 import Test.Framework.Providers.HUnit (testCase)
9 import Text.Regex.PCRE.Light (
18 type Address = BSU.ByteString
19 type LocalPart = BSU.ByteString
20 type DomainPart = BSU.ByteString
24 -- | Split an address into local/domain parts.
25 parts :: Address -> (LocalPart, DomainPart)
30 (before, rest) = BSU.break break_func address
34 -- | Check that the lengths of the local/domain parts are within spec.
35 validate_length :: Address -> Bool
36 validate_length address =
37 (BSU.length localpart <= 64) && (BSU.length domain <= 255)
39 (localpart, domain) = parts address
41 -- | Validate an email address against a simple regex. This should
42 -- catch common addresses but disallows a lot of (legal) weird stuff.
43 validate_regex :: Address -> Bool
44 validate_regex address =
49 regex_str = "(\\w+)([\\w\\-\\.]*)@(([a-z0-9\\-]+\\.)+)[a-z]{2,4}$"
50 regex_bs = BSU.fromString regex_str
51 regex = compile regex_bs [anchored, caseless, dollar_endonly, utf8]
52 matches = match regex address []
57 good_addresses :: [Address]
61 "philq23562@hotmail.com",
62 "gsdfg22-2_22@hot-mail.com",
63 "bill.w@sub.domain.com",
64 "paul@sub.domain.co.uk",
65 "someone_45@someplace.info" ]
67 bad_addresses :: [Address]
70 "bad%char@domain.com",
71 "bad^char@domain.com",
72 "badunderscore@dom_ain.com",
74 "no spaces@domain.com",
75 ".beginswith@a-dot.com" ]
77 unsupported_addresses :: [Address]
78 unsupported_addresses =
94 "tom.phillips@[127.0.0.1]" ]
96 test_good_addresses :: Test
99 assertEqual desc expected actual
101 desc = "Good addresses are accepted."
103 actual = and (map validate_regex good_addresses)
105 test_bad_addresses :: Test
108 assertEqual desc expected actual
110 desc = "Bad addresses are not accepted."
112 actual = and (map (not . validate_regex) bad_addresses)
114 test_unsupported_addresses :: Test
115 test_unsupported_addresses =
117 assertEqual desc expected actual
119 desc = "Unsupported addresses are not accepted."
121 actual = and (map (not . validate_regex) unsupported_addresses)
124 email_address_tests :: Test
125 email_address_tests =
126 testGroup "EmailAddress Tests" [
129 test_unsupported_addresses ]