module Main where import Control.Concurrent.ParallelIO.Global ( parallel, stopGlobalPool ) import qualified Data.ByteString.Char8 as BS ( getContents, pack, words ) import Data.List ((\\)) import Data.String.Utils (join) import Network.DNS ( Domain, FileOrNumericHost(RCHostName), ResolvConf(resolvInfo), defaultResolvConf, lookupNS, makeResolvSeed, withResolver ) import CommandLine (Args(..), get_args) import DNS (normalize) report :: (Domain, Maybe [Domain]) -> IO () report (d, Nothing) = putStrLn $ "Domain " ++ (show d) ++ " not delegated." report (d, Just leftovers) = if null leftovers then return () else putStrLn $ "Domain " ++ (show d) ++ " delegates somewhere else: " ++ (join " " (map show leftovers)) clean :: [Domain] -- ^ List of delegates, @ds@ -> (Domain, Maybe [Domain]) -- ^ Pairs of (domain name, lookup result) -> (Domain, Maybe [Domain]) clean _ p@(_, Nothing) = p clean ds (d, Just targets) = (d, Just $ targets \\ ds) main :: IO () main = do cfg <- get_args -- This reads stdin. input <- BS.getContents -- Split the input on any whitespace characters. let raw_domains = BS.words input -- Convert these to ByteStrings. let raw_delegates = map BS.pack (delegates cfg) -- Normalize the given names and delegates let nrml_domains = map normalize raw_domains let nrml_delegates = map normalize raw_delegates let rc = case (server cfg) of Nothing -> defaultResolvConf Just s -> defaultResolvConf { resolvInfo = RCHostName s } rs <- makeResolvSeed rc withResolver rs $ \resolver -> do -- This function keeps the domain matches with its NS records. let lookupNS' = \d -> (lookupNS resolver d) >>= (return . ((,) d)) -- Bad stuff happens if we try to run these lookups in parallel -- instead of the reports. domains_ns <- mapM lookupNS' nrml_domains let cdns = map (clean nrml_delegates) domains_ns _ <- case cfg of (NS _ _) -> -- We're only checking NS records, so report what we found. parallel (map report cdns) (MX _ _) -> return [()] stopGlobalPool