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