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