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 = BS.tail rest
  32
  33
  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)
  38   where
  39     (localpart, domain) = parts address
  40
  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 =
  45   case matches of
  46     Nothing -> False
  47     _       -> True
  48   where
  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 []
  53
  54
  55
  56 -- HUnit tests
  57 good_addresses :: [Address]
  58 good_addresses =
  59   map BSU.fromString [
  60     "phil@hotmail.com",
  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" ]
  66
  67 bad_addresses :: [Address]
  68 bad_addresses =
  69   map BSU.fromString [
  70     "bad%char@domain.com",
  71     "bad^char@domain.com",
  72     "badunderscore@dom_ain.com",
  73     "(fail)@domain.com",
  74     "no spaces@domain.com",
  75     ".beginswith@a-dot.com"  ]
  76
  77 unsupported_addresses :: [Address]
  78 unsupported_addresses =
  79   map BSU.fromString [
  80     "ok!char@domain.com",
  81     "ok#char@domain.com",
  82     "ok$char@domain.com",
  83     "ok'char@domain.com",
  84     "ok*char@domain.com",
  85     "ok+char@domain.com",
  86     "ok/char@domain.com",
  87     "ok=char@domain.com",
  88     "ok?char@domain.com",
  89     "ok`char@domain.com",
  90     "ok{char@domain.com",
  91     "ok|char@domain.com",
  92     "ok}char@domain.com",
  93     "ok~char@domain.com",
  94     "tom.phillips@[127.0.0.1]" ]
  95
  96 test_good_addresses :: Test
  97 test_good_addresses =
  98   testCase desc $
  99     assertEqual desc expected actual
 100   where
 101     desc = "Good addresses are accepted."
 102     expected = True
 103     actual = and (map validate_regex good_addresses)
 104
 105 test_bad_addresses :: Test
 106 test_bad_addresses =
 107   testCase desc $
 108     assertEqual desc expected actual
 109   where
 110     desc = "Bad addresses are not accepted."
 111     expected = True
 112     actual = and (map (not . validate_regex) bad_addresses)
 113
 114 test_unsupported_addresses :: Test
 115 test_unsupported_addresses =
 116   testCase desc $
 117     assertEqual desc expected actual
 118   where
 119     desc = "Unsupported addresses are not accepted."
 120     expected = True
 121     actual = and (map (not . validate_regex) unsupported_addresses)
 122
 123
 124 email_address_tests :: Test
 125 email_address_tests =
 126   testGroup "EmailAddress Tests" [
 127     test_good_addresses,
 128     test_bad_addresses,
 129     test_unsupported_addresses ]