module EmailAddress
where

import qualified Data.ByteString as BS
import qualified Data.ByteString.UTF8 as BSU
import Test.HUnit (assertEqual)
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.HUnit (testCase)
import Text.Regex.PCRE.Light (
  anchored,
  caseless,
  compile,
  dollar_endonly,
  match,
  utf8
  )

type Address = BSU.ByteString
type LocalPart = BSU.ByteString
type DomainPart = BSU.ByteString



-- | Split an address into local/domain parts.
parts :: Address -> (LocalPart, DomainPart)
parts address =
  (before, after)
  where
    break_func = (== '@')
    (before, rest) = BSU.break break_func address
    after =
      if rest == BS.empty
      then BS.empty
      else BS.tail rest


-- | Check that the lengths of the local/domain parts are within spec.
validate_length :: Address -> Bool
validate_length address =
  (BSU.length localpart <= 64) && (BSU.length domain <= 255)
  where
    (localpart, domain) = parts address

-- | Validate an email address against a simple regex. This should
--   catch common addresses but disallows a lot of (legal) weird stuff.
validate_regex :: Address -> Bool
validate_regex address =
  case matches of
    Nothing -> False
    _       -> True
  where
    regex_str = "(\\w+)([\\w\\-\\.]*)@(([a-z0-9\\-]+\\.)+)[a-z]{2,4}$"
    regex_bs  = BSU.fromString regex_str
    regex = compile regex_bs [anchored, caseless, dollar_endonly, utf8]
    matches = match regex address []


-- | Validate the syntax of an email address by checking its length
--   and validating it against a simple regex.
validate_syntax :: Address -> Bool
validate_syntax address =
  (validate_length address) && (validate_regex address)


-- HUnit tests
good_addresses :: [Address]
good_addresses =
  map BSU.fromString [
    "phil@hotmail.com",
    "philq23562@hotmail.com",
    "gsdfg22-2_22@hot-mail.com",
    "bill.w@sub.domain.com",
    "paul@sub.domain.co.uk",
    "someone_45@someplace.info" ]

bad_addresses :: [Address]
bad_addresses =
  map BSU.fromString [
    "bad%char@domain.com",
    "bad^char@domain.com",
    "badunderscore@dom_ain.com",
    "(fail)@domain.com",
    "no spaces@domain.com",
    ".beginswith@a-dot.com",
    "a",
    "a.com",
    "@b.com",
    "b@",
    (replicate 65 'a') ++ "@" ++ "domain.com",
    "abcdefg@" ++ (replicate 253 'a') ++ ".com",
    (replicate 100 'a') ++ "@" ++ (replicate 300 'a') ++ ".com" ]

unsupported_addresses :: [Address]
unsupported_addresses =
  map BSU.fromString [
    "ok!char@domain.com",
    "ok#char@domain.com",
    "ok$char@domain.com",
    "ok'char@domain.com",
    "ok*char@domain.com",
    "ok+char@domain.com",
    "ok/char@domain.com",
    "ok=char@domain.com",
    "ok?char@domain.com",
    "ok`char@domain.com",
    "ok{char@domain.com",
    "ok|char@domain.com",
    "ok}char@domain.com",
    "ok~char@domain.com",
    "tom.phillips@[127.0.0.1]" ]

test_good_addresses :: Test
test_good_addresses =
  testCase desc $
    assertEqual desc expected actual
  where
    desc = "Good addresses are accepted."
    expected = True
    actual = all validate_syntax good_addresses

test_bad_addresses :: Test
test_bad_addresses =
  testCase desc $
    assertEqual desc expected actual
  where
    desc = "Bad addresses are not accepted."
    expected = True
    actual = all (not . validate_syntax) bad_addresses

test_unsupported_addresses :: Test
test_unsupported_addresses =
  testCase desc $
    assertEqual desc expected actual
  where
    desc = "Unsupported addresses are not accepted."
    expected = True
    actual = all (not . validate_syntax) unsupported_addresses


email_address_tests :: Test
email_address_tests =
  testGroup "EmailAddress Tests" [
    test_good_addresses,
    test_bad_addresses,
    test_unsupported_addresses ]