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   normalize_case,
  32   resolve_address )
  33 import ExitCodes (exit_bad_server)
  34
  35 report :: (Domain, Maybe [Domain]) -> IO ()
  36 report (d, Nothing) =
  37   putStrLn $ "Domain " ++ (show d) ++ " not delegated."
  38 report (d, Just leftovers) =
  39   unless (null leftovers) $
  40     putStrLn $ "Domain " ++
  41                (show d) ++
  42                " delegates somewhere else: " ++
  43                (join " " (map show leftovers))
  44
  45 clean :: [Domain] -- ^ List of delegates, @ds@
  46       -> LookupResult
  47       -> LookupResult
  48 clean _ p@(_, Nothing) = p
  49 clean delgts (d, Just targets) =
  50   (d, Just $ targets \\ delgts)
  51
  52
  53
  54 main :: IO ()
  55 main = do
  56   cfg <- get_args
  57
  58   -- This reads stdin.
  59   input <- BS.getContents
  60
  61   -- Split the input on any whitespace characters.
  62   let raw_domains = BS.words input
  63
  64   -- Convert these to ByteStrings.
  65   let raw_delegates = map BS.pack (delegates cfg)
  66
  67   let normalize_function =
  68         if (no_append_root cfg)
  69         then normalize_case
  70         else normalize
  71
  72   -- Normalize the given names and delegates
  73   let nrml_domains   = map normalize_function raw_domains
  74   let nrml_delegates = map normalize_function raw_delegates
  75
  76   rc <- case (server cfg) of
  77           Nothing -> return defaultResolvConf
  78           Just s -> do
  79             s' <- resolve_address s
  80             case s' of
  81               Nothing -> do
  82                 hPutStrLn stderr ("Bad DNS server or lookup error: " ++ s)
  83                 exitWith (ExitFailure exit_bad_server)
  84               Just s'' ->
  85                 return $ defaultResolvConf { resolvInfo =
  86                                                RCHostName (show s'') }
  87
  88   rs <- makeResolvSeed rc
  89
  90   let lookup_function = case cfg of
  91                           (NS _ _ _) -> lookupNS'
  92                           (MX _ _ _) -> lookupMX'
  93
  94   _ <- withResolver rs $ \resolver -> do
  95          -- Bad stuff happens if we try to run these lookups in parallel
  96          -- instead of the reports.
  97          records <- mapM (lookup_function resolver) nrml_domains
  98          let cleaned_records = map (clean nrml_delegates) records
  99          parallel (map report cleaned_records)
 100
 101   stopGlobalPool