From 689bda2499ec821772b456cb7982527d6740649f Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Fri, 13 Sep 2013 09:35:40 -0400 Subject: [PATCH] Update code and doctests to support the new version of the dns library. --- src/DNS.hs | 74 ++++++++++++++++++----------------------------------- src/Main.hs | 61 ++++++++++++++++++++++++------------------- 2 files changed, 59 insertions(+), 76 deletions(-) diff --git a/src/DNS.hs b/src/DNS.hs index 61b96aa..34a8bd1 100644 --- a/src/DNS.hs +++ b/src/DNS.hs @@ -9,7 +9,6 @@ module DNS ( resolve_address ) where -import Control.Applicative ((<$>)) import Control.Monad (liftM) import qualified Data.ByteString.Char8 as BS ( append, @@ -21,18 +20,14 @@ import Data.Char (toLower) import Data.IP (IPv4) import Network.DNS ( Domain, - DNSFormat(..), + DNSError, Resolver, - RDATA(..), - TYPE(..), defaultResolvConf, lookupA, lookupMX, lookupNS, - lookupRaw, + lookupNSAuth, makeResolvSeed, - rdata, - rrtype, withResolver ) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) @@ -40,52 +35,28 @@ import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit (assertEqual) import Text.Read (readMaybe) -type LookupResult = (Domain, Maybe [Domain]) - --- | Perform a query, but take the result from the authority section --- of the response rather than the answer section. Code shamelessly --- stolen from Network.DNS.lookup. -lookup_authority :: Resolver -> Domain -> TYPE -> IO (Maybe [RDATA]) -lookup_authority rlv dom typ = (>>= toRDATA) <$> lookupRaw rlv dom typ - where - correct r = rrtype r == typ - listToMaybe [] = Nothing - listToMaybe xs = Just xs - toRDATA = listToMaybe . map rdata . filter correct . authority - --- | Like lookupNS, except we take the result from the authority --- section of the response (as opposed to the answer section). -lookupNS_authority :: Resolver -> Domain -> IO (Maybe [Domain]) -lookupNS_authority rlv dom = toNS <$> DNS.lookup_authority rlv dom NS - where - toNS = fmap (map unTag) - unTag (RD_NS dm) = dm - unTag _ = error "lookupNS_authority" - +type LookupResult = (Domain, Either DNSError [Domain]) -- | Takes a String representing either a hostname or an IP -- address. If a hostname was supplied, it is resolved to either an --- IPv4 or Nothing. If an IP address is supplied, it is returned as an --- IPv4. +-- [IPv4] or an error. If an IP address is supplied, it is returned +-- as a singleton [IPv4]. -- -- Examples: -- -- >>> resolve_address "example.com" --- Just 93.184.216.119 +-- Right [93.184.216.119] -- >>> resolve_address "93.184.216.119" --- Just 93.184.216.119 +-- Right [93.184.216.119] -- -resolve_address :: String -> IO (Maybe IPv4) +resolve_address :: String -> IO (Either DNSError [IPv4]) resolve_address s = case read_result of - Just _ -> return read_result + Just addr -> return $ Right [addr] Nothing -> do default_rs <- makeResolvSeed defaultResolvConf - withResolver default_rs $ \resolver -> do - result <- lookupA resolver (BS.pack s) - return $ case result of - Just (x:_) -> Just x - _ -> Nothing + withResolver default_rs $ \resolver -> + lookupA resolver (BS.pack s) where read_result :: Maybe IPv4 read_result = readMaybe s @@ -102,13 +73,14 @@ resolve_address s = -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> let domain = BS.pack "example.com." -- >>> withResolver rs $ \resolver -> lookupMX' resolver domain --- ("example.com.",Nothing) +-- ("example.com.",Right []) -- lookupMX' :: Resolver -> Domain -> IO LookupResult lookupMX' resolver domain = liftM (pair_em . drop_priority) $ lookupMX resolver domain where - drop_priority :: Maybe [(Domain, Int)] -> Maybe [Domain] + drop_priority :: Either DNSError [(Domain, Int)] + -> Either DNSError [Domain] drop_priority = fmap (map fst) pair_em :: a -> (Domain, a) @@ -126,26 +98,30 @@ lookupMX' resolver domain = -- them to get a reliable result. -- -- >>> import Data.List (sort) +-- >>> import Control.Applicative ((<$>)) +-- >>> -- >>> let sort_snd (x,y) = (x, sort <$> y) -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> let domain = BS.pack "example.com." -- >>> withResolver rs $ \resolver -> sort_snd <$> lookupNS' resolver domain --- ("example.com.",Just ["a.iana-servers.net.","b.iana-servers.net."]) +-- ("example.com.",Right ["a.iana-servers.net.","b.iana-servers.net."]) -- lookupNS' :: Resolver -> Domain -> IO LookupResult lookupNS' resolver domain = do answer_result <- lookupNS resolver domain - auth_result <- lookupNS_authority resolver domain + auth_result <- lookupNSAuth resolver domain liftM pair_em $ return $ combine answer_result auth_result where pair_em :: a -> (Domain, a) pair_em = (,) domain - combine :: (Maybe [Domain]) -> (Maybe [Domain]) -> (Maybe [Domain]) - combine Nothing Nothing = Nothing - combine m1 Nothing = m1 - combine Nothing m2 = m2 - combine (Just ds1) (Just ds2) = Just (ds1 ++ ds2) + combine :: (Either DNSError [Domain]) + -> (Either DNSError [Domain]) + -> (Either DNSError [Domain]) + combine e1 e2 = do + l1 <- e1 + l2 <- e2 + return (l1 ++ l2) -- | Perform both normalize_case and normalize_root. normalize :: Domain -> Domain diff --git a/src/Main.hs b/src/Main.hs index 4e0da6b..a5dc794 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -34,14 +34,31 @@ import ExitCodes (exit_bad_server) import Timeout (Timeout(..)) --- | Report results for this LookupResult. If there's a Nothing in the --- second component, there were no query results, so we report that --- the domain was not delegated. If there were some results and --- there are leftovers (after "cleaning"), we report those as well. -report :: LookupResult -> IO () -report (d, Nothing) = +-- | Given a list of delegates, report results for this +-- LookupResult. +-- +-- If there's an empty list in the second component, there were no +-- query results, so we report that the domain was not delegated. If +-- there were some results and there are leftovers (after removing +-- the delegates), we report those as well. +-- +report :: [Domain] -- ^ The list of @delgts@ + -> LookupResult + -> IO () + +-- If the lookup resulted in a DNS error, we just ignore the whole +-- thing. +report _ (_, Left _) = return () + +-- If the lookup succeeded but there were no results, report that the +-- domain is not delegated. +report _ (d, Right []) = putStrLn $ "Domain " ++ (show d) ++ " not delegated." -report (d, Just leftovers) = + +-- Otherwise, subtract our delegates from the list of results and +-- report the leftovers. +report delgts (d, Right hosts) = do + let leftovers = hosts \\ delgts unless (null leftovers) $ putStrLn $ "Domain " ++ (show d) ++ @@ -49,19 +66,6 @@ report (d, Just leftovers) = (join " " (map show leftovers)) --- | "Clean" a lookup result by subtracting out the list of delegates. --- There shouldn't be anything left over. If there were no lookup --- results, we leave the Nothing in place so that 'report' can --- pattern match on it. -clean :: [Domain] -- ^ List of delegates, @ds@ - -> LookupResult - -> LookupResult -clean _ p@(_, Nothing) = p -clean delgts (d, Just targets) = - (d, Just $ targets \\ delgts) - - - main :: IO () main = do cfg <- get_args @@ -89,16 +93,20 @@ main = do Just s -> do s' <- resolve_address s case s' of - Nothing -> do - hPutStrLn stderr ("Bad DNS server or lookup error: " ++ s) + Left err -> do + let errmsg = show err + hPutStrLn stderr ("Bad DNS server or lookup error: " ++ errmsg) + exitWith (ExitFailure exit_bad_server) + Right [] -> do + hPutStrLn stderr ("Hostname " ++ s ++ " has no 'A' records.") exitWith (ExitFailure exit_bad_server) - Just s'' -> + Right (srv:_) -> return $ defaultResolvConf { resolvInfo = - RCHostName (show s'') } + RCHostName (show srv) } -- Set the timeout from the command line. The resolvTimeout field is -- in microseconds, so we multiply by one million. - let rc = rc' { resolvTimeout = 1000 * 1000 * (seconds $ timeout cfg) } + let rc = rc' { resolvTimeout = 1000 * 1000 * seconds (timeout cfg) } rs <- makeResolvSeed rc let lookup_function = case cfg of @@ -109,7 +117,6 @@ main = do -- Bad stuff happens if we try to run these lookups in parallel -- instead of the reports. records <- mapM (lookup_function resolver) nrml_domains - let cleaned_records = map (clean nrml_delegates) records - parallel (map report cleaned_records) + parallel (map (report nrml_delegates) records) stopGlobalPool -- 2.43.2