src/EmailAddress.hs

   1 module EmailAddress
   2 where
   3
   4 import qualified Data.ByteString.Char8 as BS (
   5   ByteString,
   6   break,
   7   empty,
   8   length,
   9   pack,
  10   tail)
  11 import Text.Email.Validate (isValid)
  12 import Test.HUnit (assertEqual)
  13 import Test.Framework (Test, testGroup)
  14 import Test.Framework.Providers.HUnit (testCase)
  15 import Text.Regex.PCRE.Light (
  16   anchored,
  17   caseless,
  18   compile,
  19   dollar_endonly,
  20   match,
  21   utf8
  22   )
  23
  24 type Address = BS.ByteString
  25 type LocalPart = BS.ByteString
  26 type DomainPart = BS.ByteString
  27
  28
  29
  30 -- | Split an address into local/domain parts.
  31 parts :: Address -> (LocalPart, DomainPart)
  32 parts address =
  33   (before, after)
  34   where
  35     break_func = (== '@')
  36     (before, rest) = BS.break break_func address
  37     after =
  38       if rest == BS.empty
  39       then BS.empty
  40       else BS.tail rest
  41
  42
  43 -- | Check that the lengths of the local/domain parts are within spec.
  44 validate_length :: Address -> Bool
  45 validate_length address =
  46   (BS.length localpart <= 64) && (BS.length domain <= 255)
  47   where
  48     (localpart, domain) = parts address
  49
  50 -- | Validate an email address against a simple regex. This should
  51 --   catch common addresses but disallows a lot of (legal) weird stuff.
  52 validate_regex :: Address -> Bool
  53 validate_regex address =
  54   case matches of
  55     Nothing -> False
  56     _       -> True
  57   where
  58     regex_str = "(\\w+)([\\w\\-\\.]*)@(([a-z0-9\\-]+\\.)+)[a-z]{2,4}$"
  59     regex_bs  = BS.pack regex_str
  60     regex = compile regex_bs [anchored, caseless, dollar_endonly, utf8]
  61     matches = match regex address []
  62
  63
  64 -- | Validate the syntax of an email address by checking its length
  65 --   and validating it against either a simple regex or RFC5322,
  66 --   depending on the --rfc5322 flag.
  67 validate_syntax :: Bool -> Address -> Bool
  68 validate_syntax rfc5322 address =
  69   (validate_length address) &&
  70     if rfc5322
  71     then isValid address
  72     else validate_regex address
  73
  74
  75 -- HUnit tests
  76 good_addresses :: [Address]
  77 good_addresses =
  78   map BS.pack [
  79     "phil@hotmail.com",
  80     "philq23562@hotmail.com",
  81     "gsdfg22-2_22@hot-mail.com",
  82     "bill.w@sub.domain.com",
  83     "paul@sub.domain.co.uk",
  84     "someone_45@someplace.info" ]
  85
  86 bad_addresses :: [Address]
  87 bad_addresses =
  88   map BS.pack [
  89     -- Bad, but not caught by email-validate-0.0.1.
  90     --  "badunderscore@dom_ain.com",
  91     "(fail)@domain.com",
  92     "no spaces@domain.com",
  93     ".beginswith@a-dot.com",
  94     "a",
  95     "a.com",
  96     "@b.com",
  97     "b@",
  98     (replicate 65 'a') ++ "@" ++ "domain.com",
  99     "abcdefg@" ++ (replicate 253 'a') ++ ".com",
 100     (replicate 100 'a') ++ "@" ++ (replicate 300 'a') ++ ".com" ]
 101
 102 unsupported_addresses :: [Address]
 103 unsupported_addresses =
 104   map BS.pack [
 105     "ok!char@domain.com",
 106     "ok#char@domain.com",
 107     "ok$char@domain.com",
 108     "ok'char@domain.com",
 109     "ok*char@domain.com",
 110     "ok+char@domain.com",
 111     "ok/char@domain.com",
 112     "ok=char@domain.com",
 113     "ok?char@domain.com",
 114     "ok`char@domain.com",
 115     "ok{char@domain.com",
 116     "ok|char@domain.com",
 117     "ok}char@domain.com",
 118     "ok~char@domain.com",
 119     "tom.phillips@[127.0.0.1]",
 120     "bad%char@domain.com",
 121     "bad^char@domain.com" ]
 122
 123 test_good_addresses :: Test
 124 test_good_addresses =
 125   testCase desc $
 126     assertEqual desc expected actual
 127   where
 128     desc = "Good addresses are accepted."
 129     expected = True
 130     actual = all (validate_syntax False) good_addresses
 131
 132 test_good_addresses_rfc :: Test
 133 test_good_addresses_rfc =
 134   testCase desc $
 135     assertEqual desc expected actual
 136   where
 137     desc = "Good addresses are accepted with --rfc5322."
 138     expected = True
 139     actual = all (validate_syntax True) good_addresses
 140
 141 test_bad_addresses :: Test
 142 test_bad_addresses =
 143   testCase desc $
 144     assertEqual desc expected actual
 145   where
 146     desc = "Bad addresses are not accepted."
 147     expected = True
 148     actual = all (not . (validate_syntax False)) bad_addresses
 149
 150 test_bad_addresses_rfc :: Test
 151 test_bad_addresses_rfc =
 152   testCase desc $
 153     assertEqual desc expected actual
 154   where
 155     desc = "Bad addresses are not accepted with --rfc5322."
 156     expected = True
 157     actual = all (not . (validate_syntax True)) bad_addresses
 158
 159 test_unsupported_addresses :: Test
 160 test_unsupported_addresses =
 161   testCase desc $
 162     assertEqual desc expected actual
 163   where
 164     desc = "Unsupported addresses are not accepted."
 165     expected = True
 166     actual = all (not . (validate_syntax False)) unsupported_addresses
 167
 168 test_unsupported_addresses_rfc :: Test
 169 test_unsupported_addresses_rfc =
 170   testCase desc $
 171     assertEqual desc expected actual
 172   where
 173     desc = "Unsupported addresses are accepted with --rfc5322."
 174     expected = True
 175     actual = all (validate_syntax True) unsupported_addresses
 176
 177 email_address_tests :: Test
 178 email_address_tests =
 179   testGroup "EmailAddress Tests" [
 180     test_good_addresses,
 181     test_good_addresses_rfc,
 182     test_bad_addresses,
 183     test_bad_addresses_rfc,
 184     test_unsupported_addresses,
 185     test_unsupported_addresses_rfc ]