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, resolvTimeout),
  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   normalize_case,
  32   resolve_address )
  33 import ExitCodes (exit_bad_server)
  34 import Timeout (Timeout(..))
  35
  36
  37 -- | Given a list of delegates, report results for this
  38 --   LookupResult.
  39 --
  40 --   If there's an empty list in the second component, there were no
  41 --   query results, so we report that the domain was not delegated. If
  42 --   there were some results and there are leftovers (after removing
  43 --   the delegates), we report those as well.
  44 --
  45 report :: [Domain] -- ^ The list of @delgts@
  46        -> LookupResult
  47        -> IO ()
  48
  49 -- If the lookup resulted in a DNS error, we just ignore the whole
  50 -- thing.
  51 report _ (_, Left _) = return ()
  52
  53 -- If the lookup succeeded but there were no results, report that the
  54 -- domain is not delegated.
  55 report _ (d, Right []) =
  56   putStrLn $ "Domain " ++ (show d) ++ " not delegated."
  57
  58 -- Otherwise, subtract our delegates from the list of results and
  59 -- report the leftovers.
  60 report delgts (d, Right hosts) = do
  61   let leftovers = hosts \\ delgts
  62   unless (null leftovers) $
  63     putStrLn $ "Domain " ++
  64                (show d) ++
  65                " delegates somewhere else: " ++
  66                (join " " (map show leftovers))
  67
  68
  69 main :: IO ()
  70 main = do
  71   cfg <- get_args
  72
  73   -- This reads stdin.
  74   input <- BS.getContents
  75
  76   -- Split the input on any whitespace characters.
  77   let raw_domains = BS.words input
  78
  79   -- Convert these to ByteStrings.
  80   let raw_delegates = map BS.pack (delegates cfg)
  81
  82   let normalize_function =
  83         if (no_append_root cfg)
  84         then normalize_case
  85         else normalize
  86
  87   -- Normalize the given names and delegates
  88   let nrml_domains   = map normalize_function raw_domains
  89   let nrml_delegates = map normalize_function raw_delegates
  90
  91   rc' <- case (server cfg) of
  92            Nothing -> return defaultResolvConf
  93            Just s -> do
  94              s' <- resolve_address s
  95              case s' of
  96                Left err -> do
  97                  let errmsg = show err
  98                  hPutStrLn stderr ("Bad DNS server or lookup error: " ++ errmsg)
  99                  exitWith (ExitFailure exit_bad_server)
 100                Right []  -> do
 101                  hPutStrLn stderr ("Hostname " ++ s ++ " has no 'A' records.")
 102                  exitWith (ExitFailure exit_bad_server)
 103                Right (srv:_) ->
 104                  return $ defaultResolvConf { resolvInfo =
 105                                                 RCHostName (show srv) }
 106
 107   -- Set the timeout from the command line. The resolvTimeout field is
 108   -- in microseconds, so we multiply by one million.
 109   let rc = rc' { resolvTimeout = 1000 * 1000 * seconds (timeout cfg) }
 110   rs <- makeResolvSeed rc
 111
 112   let lookup_function = case cfg of
 113                           NS{} -> lookupNS'
 114                           MX{} -> lookupMX'
 115
 116   _ <- withResolver rs $ \resolver -> do
 117          -- Bad stuff happens if we try to run these lookups in parallel
 118          -- instead of the reports.
 119          records <- mapM (lookup_function resolver) nrml_domains
 120          parallel (map (report nrml_delegates) records)
 121
 122   stopGlobalPool