src/Main.hs: fix handling of "domain not found" errors.
[haeredes.git] / src / Main.hs
1 module Main (main)
2 where
3
4 import Control.Concurrent.ParallelIO.Global (
5 parallelInterleaved,
6 stopGlobalPool )
7 import Control.Monad (unless)
8 import qualified Data.ByteString.Char8 as BS (
9 getContents,
10 pack,
11 words )
12 import Data.List ( (\\), intersperse )
13 import Network.DNS (
14 DNSError(NameError),
15 Domain,
16 FileOrNumericHost(RCHostName),
17 ResolvConf(resolvInfo, resolvTimeout),
18 defaultResolvConf,
19 makeResolvSeed,
20 normalize,
21 normalizeCase,
22 withResolver )
23 import System.Exit (ExitCode(ExitFailure), exitWith)
24 import System.IO (hPutStrLn, stderr)
25
26 import CommandLine (
27 Args(NS,MX,delegates,no_append_root,server,timeout),
28 get_args)
29 import DNS (
30 LookupResult,
31 lookupMX',
32 lookupNS',
33 resolve_address )
34 import ExitCodes (exit_bad_server)
35 import Timeout (Timeout(seconds))
36
37
38 -- | Given a list of delegates, report results for this
39 -- 'LookupResult'.
40 --
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.
45 --
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.
49 --
50 report :: [Domain] -- ^ The list of @delgts@
51 -> (Domain -> Domain) -- ^ Domain name normalization function,
52 -- @normalize_function@.
53 -> LookupResult
54 -> IO ()
55
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."
63
64 -- If the lookup resulted in some other DNS error, we just ignore the
65 -- whole thing.
66 report _ _ (_, Left _) = return ()
67
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 " ++
75 (show d) ++
76 " delegates somewhere else: " ++
77 (join " " (map show leftovers))
78 where
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)
83
84
85 main :: IO ()
86 main = do
87 cfg <- get_args
88
89 -- This reads stdin.
90 input <- BS.getContents
91
92 -- Split the input on any whitespace characters.
93 let raw_domains = BS.words input
94
95 -- Convert these to ByteStrings.
96 let raw_delegates = map BS.pack (delegates cfg)
97
98 let normalize_function =
99 if (no_append_root cfg)
100 then normalizeCase
101 else normalize
102
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
106
107 rc' <- case (server cfg) of
108 Nothing -> return defaultResolvConf
109 Just s -> do
110 s' <- resolve_address s
111 case s' of
112 Left err -> do
113 let errmsg = show err
114 hPutStrLn stderr ("Bad DNS server or lookup error: " ++ errmsg)
115 exitWith (ExitFailure exit_bad_server)
116 Right [] -> do
117 hPutStrLn stderr ("Hostname " ++ s ++ " has no 'A' records.")
118 exitWith (ExitFailure exit_bad_server)
119 Right (srv:_) ->
120 return $ defaultResolvConf { resolvInfo =
121 RCHostName (show srv) }
122
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
128
129 let lookup_function = case cfg of
130 NS{} -> lookupNS'
131 MX{} -> lookupMX'
132
133 let lookup' d = withResolver rs $ \resolver ->
134 lookup_function resolver d
135
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
139
140 -- Run the lookup actions in parallel.
141 results <- parallelInterleaved actions
142
143 -- Output the results.
144 _ <- mapM (report nrml_delegates normalize_function) results
145
146 stopGlobalPool