X-Git-Url: http://gitweb.michael.orlitzky.com/?p=haeredes.git;a=blobdiff_plain;f=src%2FMain.hs;h=4e0da6b6dc0296e730025f5295219eeaae254fe1;hp=f322baae83511743b8ceb4648f9966bddbf42e4a;hb=f9610a6d357f2ed79f2f18baa477244970f8b40f;hpb=2104fcab31ed92c308ce6b05c03d10f9f8b4cf16 diff --git a/src/Main.hs b/src/Main.hs index f322baa..4e0da6b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -14,7 +14,7 @@ import Data.String.Utils (join) import Network.DNS ( Domain, FileOrNumericHost(RCHostName), - ResolvConf(resolvInfo), + ResolvConf(resolvInfo, resolvTimeout), defaultResolvConf, makeResolvSeed, withResolver ) @@ -31,6 +31,7 @@ import DNS ( normalize_case, resolve_address ) import ExitCodes (exit_bad_server) +import Timeout (Timeout(..)) -- | Report results for this LookupResult. If there's a Nothing in the @@ -83,23 +84,26 @@ main = do let nrml_domains = map normalize_function raw_domains let nrml_delegates = map normalize_function raw_delegates - rc <- case (server cfg) of - Nothing -> return defaultResolvConf - Just s -> do - s' <- resolve_address s - case s' of - Nothing -> do - hPutStrLn stderr ("Bad DNS server or lookup error: " ++ s) - exitWith (ExitFailure exit_bad_server) - Just s'' -> - return $ defaultResolvConf { resolvInfo = - RCHostName (show s'') } - + rc' <- case (server cfg) of + Nothing -> return defaultResolvConf + Just s -> do + s' <- resolve_address s + case s' of + Nothing -> do + hPutStrLn stderr ("Bad DNS server or lookup error: " ++ s) + exitWith (ExitFailure exit_bad_server) + Just s'' -> + return $ defaultResolvConf { resolvInfo = + RCHostName (show s'') } + + -- 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) } rs <- makeResolvSeed rc let lookup_function = case cfg of - (NS _ _ _) -> lookupNS' - (MX _ _ _) -> lookupMX' + NS{} -> lookupNS' + MX{} -> lookupMX' _ <- withResolver rs $ \resolver -> do -- Bad stuff happens if we try to run these lookups in parallel