src/DNS.hs

   1 module DNS (
   2   LookupResult,
   3   lookupMX',
   4   lookupNS',
   5   normalize,
   6   resolve_address )
   7 where
   8
   9 import Control.Applicative ((<$>))
  10 import Control.Monad (liftM)
  11 import qualified Data.ByteString.Char8 as BS (
  12   append,
  13   last,
  14   map,
  15   pack )
  16 import Data.Char (toLower)
  17 import Data.IP (IPv4)
  18 import Network.DNS (
  19   Domain,
  20   DNSFormat(..),
  21   Resolver,
  22   RDATA(..),
  23   TYPE(..),
  24   defaultResolvConf,
  25   lookupA,
  26   lookupMX,
  27   lookupNS,
  28   lookupRaw,
  29   makeResolvSeed,
  30   rdata,
  31   rrtype,
  32   withResolver )
  33 import Text.Read (readMaybe)
  34
  35 type LookupResult = (Domain, Maybe [Domain])
  36
  37 -- | Perform a query, but take the result from the authority section
  38 --   of the response rather than the answer section. Code shamelessly
  39 --   stolen from Network.DNS.lookup.
  40 lookup_authority :: Resolver -> Domain -> TYPE -> IO (Maybe [RDATA])
  41 lookup_authority rlv dom typ = (>>= toRDATA) <$> lookupRaw rlv dom typ
  42   where
  43     correct r = rrtype r == typ
  44     listToMaybe [] = Nothing
  45     listToMaybe xs = Just xs
  46     toRDATA = listToMaybe . map rdata . filter correct . authority
  47
  48 -- | Like lookupNS, except we take the result from the authority
  49 --   section of the response (as opposed to the answer section).
  50 lookupNS_authority :: Resolver -> Domain -> IO (Maybe [Domain])
  51 lookupNS_authority rlv dom = toNS <$> DNS.lookup_authority rlv dom NS
  52   where
  53     toNS = fmap (map unTag)
  54     unTag (RD_NS dm) = dm
  55     unTag _ = error "lookupNS_authority"
  56
  57 resolve_address :: String -> IO (Maybe IPv4)
  58 resolve_address s =
  59   case read_result of
  60     Just _  -> return read_result
  61     Nothing -> do
  62       default_rs <- makeResolvSeed defaultResolvConf
  63       withResolver default_rs $ \resolver -> do
  64         result <- lookupA resolver (BS.pack s)
  65         return $ case result of
  66                    Just (x:_) -> Just x
  67                    _           -> Nothing
  68   where
  69     read_result :: Maybe IPv4
  70     read_result = readMaybe s
  71
  72 lookupMX' :: Resolver -> Domain -> IO LookupResult
  73 lookupMX' resolver domain =
  74   liftM (pair_em . drop_priority) $ lookupMX resolver domain
  75   where
  76     drop_priority :: Maybe [(Domain, Int)] -> Maybe [Domain]
  77     drop_priority = fmap (map fst)
  78
  79     pair_em :: a -> (Domain, a)
  80     pair_em = (,) domain
  81
  82 -- This function keeps the domain matches with its NS records.
  83 lookupNS' :: Resolver -> Domain -> IO LookupResult
  84 lookupNS' resolver domain = do
  85   answer_result <- lookupNS resolver domain
  86   auth_result <- lookupNS_authority resolver domain
  87   liftM pair_em $ return $ combine answer_result auth_result
  88   where
  89     pair_em :: a -> (Domain, a)
  90     pair_em = (,) domain
  91
  92     combine :: (Maybe [Domain]) ->  (Maybe [Domain]) -> (Maybe [Domain])
  93     combine Nothing Nothing = Nothing
  94     combine m1 Nothing = m1
  95     combine Nothing m2 = m2
  96     combine (Just ds1) (Just ds2) = Just (ds1 ++ ds2)
  97
  98 -- | Normalize the given name by lowercasing and appending a trailing
  99 --   dot (the root) if necessary.
 100 normalize :: Domain -> Domain
 101 normalize = normalize_case . normalize_root
 102
 103
 104 normalize_root :: Domain -> Domain
 105 normalize_root d
 106   | BS.last d == '.' = d
 107   | otherwise = d `BS.append` trailing_dot
 108     where
 109       trailing_dot = BS.pack "."
 110
 111
 112 normalize_case :: Domain -> Domain
 113 normalize_case = BS.map toLower