src/DNS.hs

   1 module DNS (
   2   dns_properties,
   3   dns_tests,
   4   lookup_mxs,
   5   normalize )
   6 where
   7
   8 import qualified Data.ByteString.Char8 as BS (
   9   append,
  10   last,
  11   map,
  12   null,
  13   pack )
  14 import Data.Char ( toLower )
  15 import Network.DNS (
  16   Domain,
  17   defaultResolvConf,
  18   lookupMX,
  19   makeResolvSeed,
  20   withResolver )
  21 import Test.Tasty ( TestTree, testGroup )
  22 import Test.Tasty.HUnit ( (@?=), testCase )
  23 import Test.Tasty.QuickCheck ( testProperty )
  24
  25 -- Slow since we create the resolver every time.
  26 lookup_mxs :: Domain -> IO [Domain]
  27 lookup_mxs domain = do
  28   default_rs <- makeResolvSeed defaultResolvConf
  29   withResolver default_rs $ \resolver -> do
  30     mxs <- lookupMX resolver domain
  31     return $ case mxs of
  32                Left  _     -> []
  33                Right pairs -> map fst pairs
  34
  35
  36 -- | Perform both normalize_case and normalize_root.
  37 normalize :: Domain -> Domain
  38 normalize = normalize_case . normalize_root
  39
  40 -- | Normalize the given name by appending a trailing dot (the DNS
  41 --   root) if necessary.
  42 --
  43 normalize_root :: Domain -> Domain
  44 normalize_root d
  45   | BS.null d = BS.pack "."
  46   | BS.last d == '.' = d
  47   | otherwise = d `BS.append` trailing_dot
  48     where
  49       trailing_dot = BS.pack "."
  50
  51
  52 -- | Normalize the given name by lowercasing it.
  53 --
  54 normalize_case :: Domain -> Domain
  55 normalize_case = BS.map toLower
  56
  57 -- * Tests
  58
  59 test_normalize_case :: TestTree
  60 test_normalize_case =
  61   testCase desc $ actual @?= expected
  62   where
  63     desc = "normalize_case lowercases DNS names"
  64     expected = BS.pack "example.com"
  65     actual = normalize_case $ BS.pack "ExAmPlE.COM"
  66
  67 prop_normalize_case_idempotent :: TestTree
  68 prop_normalize_case_idempotent =
  69   testProperty desc $ prop
  70   where
  71     desc = "normalize_case is idempotent"
  72
  73     prop :: String -> Bool
  74     prop s = (normalize_case . normalize_case) bs  == normalize_case bs
  75       where
  76         bs = BS.pack s
  77
  78 test_normalize_root_adds_dot :: TestTree
  79 test_normalize_root_adds_dot =
  80   testCase desc $ actual @?= expected
  81   where
  82     desc = "normalize_root adds a trailing dot"
  83     expected = BS.pack "example.com."
  84     actual = normalize_root $ BS.pack "example.com"
  85
  86 prop_normalize_root_idempotent :: TestTree
  87 prop_normalize_root_idempotent =
  88   testProperty desc prop
  89   where
  90     desc = "normalize_root is idempotent"
  91
  92     prop :: String -> Bool
  93     prop s = (normalize_root . normalize_root) bs  == normalize_root bs
  94       where
  95         bs = BS.pack s
  96
  97 dns_tests :: TestTree
  98 dns_tests =
  99   testGroup "DNS Tests" [
 100     test_normalize_case,
 101     test_normalize_root_adds_dot ]
 102
 103 dns_properties :: TestTree
 104 dns_properties =
 105   testGroup "DNS Properties" [
 106     prop_normalize_case_idempotent,
 107     prop_normalize_root_idempotent ]