Support hostnames as --server arguments.
[haeredes.git] / src / Main.hs
1 module Main
2 where
3
4 import Control.Concurrent.ParallelIO.Global (
5 parallel,
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 ((\\))
13 import Data.String.Utils (join)
14 import Network.DNS (
15 Domain,
16 FileOrNumericHost(RCHostName),
17 ResolvConf(resolvInfo),
18 defaultResolvConf,
19 makeResolvSeed,
20 withResolver )
21 import System.Exit (ExitCode(..), exitWith)
22 import System.IO (hPutStrLn, stderr)
23
24
25 import CommandLine (Args(..), get_args)
26 import DNS (
27 LookupResult,
28 lookupMX',
29 lookupNS',
30 normalize,
31 resolve_address )
32 import ExitCodes (exit_bad_server)
33
34 report :: (Domain, Maybe [Domain]) -> IO ()
35 report (d, Nothing) =
36 putStrLn $ "Domain " ++ (show d) ++ " not delegated."
37 report (d, Just leftovers) =
38 unless (null leftovers) $
39 putStrLn $ "Domain " ++
40 (show d) ++
41 " delegates somewhere else: " ++
42 (join " " (map show leftovers))
43
44 clean :: [Domain] -- ^ List of delegates, @ds@
45 -> LookupResult
46 -> LookupResult
47 clean _ p@(_, Nothing) = p
48 clean delgts (d, Just targets) =
49 (d, Just $ targets \\ delgts)
50
51
52
53 main :: IO ()
54 main = do
55 cfg <- get_args
56
57 -- This reads stdin.
58 input <- BS.getContents
59
60 -- Split the input on any whitespace characters.
61 let raw_domains = BS.words input
62
63 -- Convert these to ByteStrings.
64 let raw_delegates = map BS.pack (delegates cfg)
65
66 -- Normalize the given names and delegates
67 let nrml_domains = map normalize raw_domains
68 let nrml_delegates = map normalize raw_delegates
69
70 rc <- case (server cfg) of
71 Nothing -> return defaultResolvConf
72 Just s -> do
73 s' <- resolve_address s
74 case s' of
75 Nothing -> do
76 hPutStrLn stderr ("Bad DNS server or lookup error: " ++ s)
77 exitWith (ExitFailure exit_bad_server)
78 Just s'' ->
79 return $ defaultResolvConf { resolvInfo =
80 RCHostName (show s'') }
81
82 rs <- makeResolvSeed rc
83
84 let lookup_function = case cfg of
85 (NS _ _) -> lookupNS'
86 (MX _ _) -> lookupMX'
87
88 _ <- withResolver rs $ \resolver -> do
89 -- Bad stuff happens if we try to run these lookups in parallel
90 -- instead of the reports.
91 records <- mapM (lookup_function resolver) nrml_domains
92 let cleaned_records = map (clean nrml_delegates) records
93 parallel (map report cleaned_records)
94
95 stopGlobalPool