module EmailAddress (
  Address,
  parts,
  validate_syntax,
  -- * Test exports
  email_address_tests )
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.Tasty ( TestTree, testGroup )
import Test.Tasty.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.
--
--   Examples:
--
--   >>> let addr = BS.pack "user@example.com"
--   >>> parts addr
--   ("user","example.com")
--
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.
--
--   Examples:
--
--   >>> let jr = (replicate 64 'a') ++ "@" ++ (replicate 255 'x')
--   >>> let just_right = BS.pack jr
--   >>> validate_length just_right
--   True
--   >>> let too_long = BS.pack (jr ++ "x")
--   >>> validate_length too_long
--   False
--
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.
--
--   Examples:
--
--   >>> let addr = BS.pack "user@example.com"
--   >>> validate_regex addr
--   True
--   >>> let bad_addr = BS.pack "user@[]example.com"
--   >>> validate_regex bad_addr
--   False
--
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


-- * Tasty 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 :: TestTree
test_good_addresses =
  testCase desc $ actual @?= expected
  where
    desc = "Good addresses are accepted"
    expected = True
    actual = all (validate_syntax False) good_addresses

test_good_addresses_rfc :: TestTree
test_good_addresses_rfc =
  testCase desc $ actual @?= expected
  where
    desc = "Good addresses are accepted with --rfc5322"
    expected = True
    actual = all (validate_syntax True) good_addresses

test_bad_addresses :: TestTree
test_bad_addresses =
  testCase desc $ actual @?= expected
  where
    desc = "Bad addresses are not accepted"
    expected = True
    actual = all (not . (validate_syntax False)) bad_addresses

test_bad_addresses_rfc :: TestTree
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 :: TestTree
test_unsupported_addresses =
  testCase desc $ actual @?= expected
  where
    desc = "Unsupported addresses are not accepted"
    expected = True
    actual = all (not . (validate_syntax False)) unsupported_addresses

test_unsupported_addresses_rfc :: TestTree
test_unsupported_addresses_rfc =
  testCase desc $ actual @?= expected
  where
    desc = "Unsupported addresses are accepted with --rfc5322"
    expected = True
    actual = all (validate_syntax True) unsupported_addresses

email_address_tests :: TestTree
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 ]