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