src/DNS.hs

   1 module DNS (
   2   LookupResult,
   3   dns_properties,
   4   dns_tests,
   5   lookupMX',
   6   lookupNS',
   7   normalize,
   8   normalize_case,
   9   resolve_address )
  10 where
  11
  12 import Control.Monad (liftM)
  13 import qualified Data.ByteString.Char8 as BS (
  14   append,
  15   last,
  16   map,
  17   null,
  18   pack )
  19 import Data.Char (toLower)
  20 import Data.IP (IPv4)
  21 import Network.DNS (
  22   Domain,
  23   DNSError,
  24   Resolver,
  25   defaultResolvConf,
  26   lookupA,
  27   lookupMX,
  28   lookupNS,
  29   lookupNSAuth,
  30   makeResolvSeed,
  31   withResolver )
  32 import Test.Tasty ( TestTree, testGroup )
  33 import Test.Tasty.HUnit ( (@?=), testCase )
  34 import Test.Tasty.QuickCheck ( testProperty )
  35 import Text.Read (readMaybe)
  36
  37 type LookupResult = (Domain, Either DNSError [Domain])
  38
  39 -- | Takes a String representing either a hostname or an IP
  40 --   address. If a hostname was supplied, it is resolved to either an
  41 --   [IPv4] or an error. If an IP address is supplied, it is returned
  42 --   as a singleton [IPv4].
  43 --
  44 --   Examples:
  45 --
  46 --   >>> resolve_address "example.com"
  47 --   Right [93.184.216.119]
  48 --   >>> resolve_address "93.184.216.119"
  49 --   Right [93.184.216.119]
  50 --
  51 resolve_address :: String -> IO (Either DNSError [IPv4])
  52 resolve_address s =
  53   case read_result of
  54     Just addr  -> return $ Right [addr]
  55     Nothing -> do
  56       default_rs <- makeResolvSeed defaultResolvConf
  57       withResolver default_rs $ \resolver ->
  58         lookupA resolver (BS.pack s)
  59   where
  60     read_result :: Maybe IPv4
  61     read_result = readMaybe s
  62
  63
  64 -- | This calls lookupMX, and returns the result as the second
  65 --   component of a tuple whose first component is the domain name
  66 --   itself.
  67 --
  68 --   Examples:
  69 --
  70 --   The example domain, example.com, has no MX record.
  71 --
  72 --   >>> rs <- makeResolvSeed defaultResolvConf
  73 --   >>> let domain = BS.pack "example.com."
  74 --   >>> withResolver rs $ \resolver -> lookupMX' resolver domain
  75 --   ("example.com.",Right [])
  76 --
  77 lookupMX' :: Resolver -> Domain -> IO LookupResult
  78 lookupMX' resolver domain =
  79   liftM (pair_em . drop_priority) $ lookupMX resolver domain
  80   where
  81     drop_priority :: Either DNSError [(Domain, Int)]
  82                   -> Either DNSError [Domain]
  83     drop_priority = fmap (map fst)
  84
  85     pair_em :: a -> (Domain, a)
  86     pair_em = (,) domain
  87
  88
  89 -- | This calls lookupNS, and returns the result as the second
  90 --   component of a tuple whose first component is the domain name
  91 --   itself.
  92 --
  93 --   Examples:
  94 --
  95 --   The example domain, example.com, does have NS records, but the
  96 --   order in which they are returned is variable, so we have to sort
  97 --   them to get a reliable result.
  98 --
  99 --   >>> import Data.List (sort)
 100 --   >>> import Control.Applicative ((<$>))
 101 --   >>>
 102 --   >>> let sort_snd (x,y) = (x, sort <$> y)
 103 --   >>> rs <- makeResolvSeed defaultResolvConf
 104 --   >>> let domain = BS.pack "example.com."
 105 --   >>> withResolver rs $ \resolver -> sort_snd <$> lookupNS' resolver domain
 106 --   ("example.com.",Right ["a.iana-servers.net.","b.iana-servers.net."])
 107 --
 108 lookupNS' :: Resolver -> Domain -> IO LookupResult
 109 lookupNS' resolver domain = do
 110   answer_result <- lookupNS resolver domain
 111   auth_result <- lookupNSAuth resolver domain
 112   liftM pair_em $ return $ combine answer_result auth_result
 113   where
 114     pair_em :: a -> (Domain, a)
 115     pair_em = (,) domain
 116
 117     combine :: (Either DNSError [Domain])
 118             -> (Either DNSError [Domain])
 119             -> (Either DNSError [Domain])
 120     combine e1 e2 = do
 121       l1 <- e1
 122       l2 <- e2
 123       return (l1 ++ l2)
 124
 125 -- | Perform both normalize_case and normalize_root.
 126 normalize :: Domain -> Domain
 127 normalize = normalize_case . normalize_root
 128
 129 -- | Normalize the given name by appending a trailing dot (the DNS
 130 --   root) if necessary.
 131 --
 132 normalize_root :: Domain -> Domain
 133 normalize_root d
 134   | BS.null d = BS.pack "."
 135   | BS.last d == '.' = d
 136   | otherwise = d `BS.append` trailing_dot
 137     where
 138       trailing_dot = BS.pack "."
 139
 140
 141 -- | Normalize the given name by lowercasing it.
 142 --
 143 normalize_case :: Domain -> Domain
 144 normalize_case = BS.map toLower
 145
 146
 147
 148 -- * Tests
 149
 150 test_normalize_case :: TestTree
 151 test_normalize_case =
 152   testCase desc $ actual @?= expected
 153   where
 154     desc = "normalize_case lowercases DNS names"
 155     expected = BS.pack "example.com"
 156     actual = normalize_case $ BS.pack "ExAmPlE.COM"
 157
 158 prop_normalize_case_idempotent :: TestTree
 159 prop_normalize_case_idempotent =
 160   testProperty desc $ prop
 161   where
 162     desc = "normalize_case is idempotent"
 163
 164     prop :: String -> Bool
 165     prop s = (normalize_case . normalize_case) bs  == normalize_case bs
 166       where
 167         bs = BS.pack s
 168
 169 test_normalize_root_adds_dot :: TestTree
 170 test_normalize_root_adds_dot =
 171   testCase desc $ actual @?= expected
 172   where
 173     desc = "normalize_root adds a trailing dot"
 174     expected = BS.pack "example.com."
 175     actual = normalize_root $ BS.pack "example.com"
 176
 177 prop_normalize_root_idempotent :: TestTree
 178 prop_normalize_root_idempotent =
 179   testProperty desc prop
 180   where
 181     desc = "normalize_root is idempotent"
 182
 183     prop :: String -> Bool
 184     prop s = (normalize_root . normalize_root) bs  == normalize_root bs
 185       where
 186         bs = BS.pack s
 187
 188 dns_tests :: TestTree
 189 dns_tests =
 190   testGroup "DNS Tests" [
 191     test_normalize_case,
 192     test_normalize_root_adds_dot ]
 193
 194 dns_properties :: TestTree
 195 dns_properties =
 196   testGroup "DNS Properties" [
 197     prop_normalize_case_idempotent,
 198     prop_normalize_root_idempotent ]