4 import Control.Concurrent.ParallelIO.Global (
7 import Control.Monad (unless)
8 import qualified Data.ByteString.Char8 as BS (
12 import Data.List ( (\\), intersperse )
16 FileOrNumericHost(RCHostName),
17 ResolvConf(resolvInfo, resolvTimeout),
23 import System.Exit (ExitCode(ExitFailure), exitWith)
24 import System.IO (hPutStrLn, stderr)
27 Args(NS,MX,delegates,no_append_root,server,timeout),
34 import ExitCodes (exit_bad_server)
35 import Timeout (Timeout(seconds))
38 -- | Given a list of delegates, report results for this
41 -- If there's an empty list in the second component, there were no
42 -- query results, so we report that the domain was not delegated. If
43 -- there were some results and there are leftovers (after removing
44 -- the delegates), we report those as well.
46 -- Before processing, all names are normalized using the supplied
47 -- function @normalize_function@. Ideally this should be the same
48 -- function applied to the user-input names.
50 report :: [Domain] -- ^ The list of @delgts@
51 -> (Domain -> Domain) -- ^ Domain name normalization function,
52 -- @normalize_function@.
56 -- If the lookup succeeded but there were no results, report that the
57 -- domain is not delegated. Note that the behavior of the DNS library
58 -- changed with regard to this at some point: we used to get back
59 -- a "success," but with an empty list of results. Now a NameError
60 -- (which is not actually an error!) is returned.
61 report _ _ (d, Left NameError) =
62 putStrLn $ "Domain " ++ (show d) ++ " not delegated."
64 -- If the lookup resulted in some other DNS error, we just ignore the
66 report _ _ (_, Left _) = return ()
68 -- Otherwise, subtract our delegates from the list of results and
69 -- report the leftovers.
70 report delgts normalize_function (d, Right raw_hosts) = do
71 let nrml_hosts = map normalize_function raw_hosts
72 let leftovers = nrml_hosts \\ delgts
73 unless (null leftovers) $
74 putStrLn $ "Domain " ++
76 " delegates somewhere else: " ++
77 (join " " (map show leftovers))
79 -- Create one big string by joining together a list of smaller
80 -- strings and placing a delimiter between them.
81 join :: String -> [String] -> String
82 join delimiter strings = concat (intersperse delimiter strings)
90 input <- BS.getContents
92 -- Split the input on any whitespace characters.
93 let raw_domains = BS.words input
95 -- Convert these to ByteStrings.
96 let raw_delegates = map BS.pack (delegates cfg)
98 let normalize_function =
99 if (no_append_root cfg)
103 -- Normalize the given names and delegates
104 let nrml_domains = map normalize_function raw_domains
105 let nrml_delegates = map normalize_function raw_delegates
107 rc' <- case (server cfg) of
108 Nothing -> return defaultResolvConf
110 s' <- resolve_address s
113 let errmsg = show err
114 hPutStrLn stderr ("Bad DNS server or lookup error: " ++ errmsg)
115 exitWith (ExitFailure exit_bad_server)
117 hPutStrLn stderr ("Hostname " ++ s ++ " has no 'A' records.")
118 exitWith (ExitFailure exit_bad_server)
120 return $ defaultResolvConf { resolvInfo =
121 RCHostName (show srv) }
123 -- Set the timeout from the command line. The resolvTimeout field is
124 -- in microseconds, so we multiply by one million.
125 let a_million = 1000 * 1000 :: Int
126 let rc = rc' { resolvTimeout = a_million * seconds (timeout cfg) }
127 rs <- makeResolvSeed rc
129 let lookup_function = case cfg of
133 let lookup' d = withResolver rs $ \resolver ->
134 lookup_function resolver d
136 -- Construct a list of [IO whatever]. The withResolver calls
137 -- are the ones that should be run in parallel.
138 let actions = map lookup' nrml_domains
140 -- Run the lookup actions in parallel.
141 results <- parallelInterleaved actions
143 -- Output the results.
144 _ <- mapM (report nrml_delegates normalize_function) results