src/DNS.hs

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