module EmailAddress
where

import qualified Data.ByteString.Char8 as BS (
  ByteString,
  break,
  empty,
  length,
  pack,
  tail)
import Text.Email.Validate (isValid)
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 = BS.ByteString
type LocalPart = BS.ByteString
type DomainPart = BS.ByteString



-- | Split an address into local/domain parts.
parts :: Address -> (LocalPart, DomainPart)
parts address =
  (before, after)
  where
    break_func = (== '@')
    (before, rest) = BS.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 =
  (BS.length localpart <= 64) && (BS.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  = BS.pack 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 either a simple regex or RFC5322,
--   depending on the --rfc5322 flag.
validate_syntax :: Bool -> Address -> Bool
validate_syntax rfc5322 address =
  (validate_length address) &&
    if rfc5322
    then isValid address
    else validate_regex address


-- HUnit tests
good_addresses :: [Address]
good_addresses =
  map BS.pack [
    "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 BS.pack [
    -- Bad, but not caught by email-validate-0.0.1.
    --  "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 BS.pack [
    "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]",
    "bad%char@domain.com",
    "bad^char@domain.com" ]

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 False) good_addresses

test_good_addresses_rfc :: Test
test_good_addresses_rfc =
  testCase desc $
    assertEqual desc expected actual
  where
    desc = "Good addresses are accepted with --rfc5322."
    expected = True
    actual = all (validate_syntax True) 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 False)) bad_addresses

test_bad_addresses_rfc :: Test
test_bad_addresses_rfc =
  testCase desc $
    assertEqual desc expected actual
  where
    desc = "Bad addresses are not accepted with --rfc5322."
    expected = True
    actual = all (not . (validate_syntax True)) 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 False)) unsupported_addresses

test_unsupported_addresses_rfc :: Test
test_unsupported_addresses_rfc =
  testCase desc $
    assertEqual desc expected actual
  where
    desc = "Unsupported addresses are accepted with --rfc5322."
    expected = True
    actual = all (validate_syntax True) unsupported_addresses

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