src/EmailAddress.hs

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