resolve_address )
where
-import Control.Applicative ((<$>))
import Control.Monad (liftM)
import qualified Data.ByteString.Char8 as BS (
append,
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)
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
-- >>> 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)
-- 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
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) ++
(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
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
-- 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
projects / haeredes.git / commitdiff