module DNS (
  dns_properties,
  dns_tests,
  lookup_mxs,
  normalize )
where

import qualified Data.ByteString.Char8 as BS (
  append,
  last,
  map,
  null,
  pack )
import Data.Char ( toLower )
import Network.DNS (
  Domain,
  defaultResolvConf,
  lookupMX,
  makeResolvSeed,
  withResolver )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Test.Tasty.QuickCheck ( testProperty )

-- Slow since we create the resolver every time.
lookup_mxs :: Domain -> IO [Domain]
lookup_mxs domain = do
  default_rs <- makeResolvSeed defaultResolvConf
  withResolver default_rs $ \resolver -> do
    mxs <- lookupMX resolver domain
    return $ case mxs of
               Left  _     -> []
               Right pairs -> map fst pairs


-- | Perform both normalize_case and normalize_root.
normalize :: Domain -> Domain
normalize = normalize_case . normalize_root

-- | Normalize the given name by appending a trailing dot (the DNS
--   root) if necessary.
--
normalize_root :: Domain -> Domain
normalize_root d
  | BS.null d = BS.pack "."
  | BS.last d == '.' = d
  | otherwise = d `BS.append` trailing_dot
    where
      trailing_dot = BS.pack "."


-- | Normalize the given name by lowercasing it.
--
normalize_case :: Domain -> Domain
normalize_case = BS.map toLower

-- * Tests

test_normalize_case :: TestTree
test_normalize_case =
  testCase desc $ actual @?= expected
  where
    desc = "normalize_case lowercases DNS names"
    expected = BS.pack "example.com"
    actual = normalize_case $ BS.pack "ExAmPlE.COM"

prop_normalize_case_idempotent :: TestTree
prop_normalize_case_idempotent =
  testProperty desc $ prop
  where
    desc = "normalize_case is idempotent"

    prop :: String -> Bool
    prop s = (normalize_case . normalize_case) bs  == normalize_case bs
      where
        bs = BS.pack s

test_normalize_root_adds_dot :: TestTree
test_normalize_root_adds_dot =
  testCase desc $ actual @?= expected
  where
    desc = "normalize_root adds a trailing dot"
    expected = BS.pack "example.com."
    actual = normalize_root $ BS.pack "example.com"

prop_normalize_root_idempotent :: TestTree
prop_normalize_root_idempotent =
  testProperty desc prop
  where
    desc = "normalize_root is idempotent"

    prop :: String -> Bool
    prop s = (normalize_root . normalize_root) bs  == normalize_root bs
      where
        bs = BS.pack s

dns_tests :: TestTree
dns_tests =
  testGroup "DNS Tests" [
    test_normalize_case,
    test_normalize_root_adds_dot ]

dns_properties :: TestTree
dns_properties =
  testGroup "DNS Properties" [
    prop_normalize_case_idempotent,
    prop_normalize_root_idempotent ]