src/EmailAddress.hs

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