src/Main.hs

   1 module Main
   2 where
   3
   4 import Control.Concurrent.ParallelIO.Global (
   5   parallel,
   6   stopGlobalPool )
   7 import qualified Data.ByteString.Char8 as BS (
   8   getContents,
   9   pack,
  10   words )
  11 import Data.List ((\\))
  12 import Data.String.Utils (join)
  13
  14 import Network.DNS (
  15   Domain,
  16   FileOrNumericHost(RCHostName),
  17   ResolvConf(resolvInfo),
  18   defaultResolvConf,
  19   lookupNS,
  20   makeResolvSeed,
  21   withResolver )
  22
  23 import CommandLine (Args(..), get_args)
  24 import DNS (normalize)
  25
  26 report :: (Domain, Maybe [Domain]) -> IO ()
  27 report (d, Nothing) =
  28   putStrLn $ "Domain " ++ (show d) ++ " not delegated."
  29 report (d, Just leftovers) =
  30   if null leftovers
  31   then return ()
  32   else putStrLn $ "Domain " ++
  33                   (show d) ++
  34                   " delegates somewhere else: " ++
  35                   (join " " (map show leftovers))
  36
  37 clean :: [Domain] -- ^ List of delegates, @ds@
  38       -> (Domain, Maybe [Domain]) -- ^ Pairs of (domain name, lookup result)
  39       -> (Domain, Maybe [Domain])
  40 clean _ p@(_, Nothing) = p
  41 clean ds (d, Just targets) =
  42   (d, Just $ targets \\ ds)
  43
  44
  45 main :: IO ()
  46 main = do
  47   cfg <- get_args
  48
  49   -- This reads stdin.
  50   input <- BS.getContents
  51
  52   -- Split the input on any whitespace characters.
  53   let raw_domains = BS.words input
  54
  55   -- Convert these to ByteStrings.
  56   let raw_delegates = map BS.pack (delegates cfg)
  57
  58   -- Normalize the given names and delegates
  59   let nrml_domains   = map normalize raw_domains
  60   let nrml_delegates = map normalize raw_delegates
  61
  62   let rc = case (server cfg) of
  63              Nothing -> defaultResolvConf
  64              Just s -> defaultResolvConf { resolvInfo = RCHostName s }
  65
  66   rs <- makeResolvSeed rc
  67   withResolver rs $ \resolver -> do
  68     -- This function keeps the domain matches with its NS records.
  69     let lookupNS' = \d -> (lookupNS resolver d) >>= (return . ((,) d))
  70
  71     -- Bad stuff happens if we try to run these lookups in parallel
  72     -- instead of the reports.
  73     domains_ns <- mapM lookupNS' nrml_domains
  74     let cdns = map (clean nrml_delegates) domains_ns
  75
  76     _ <- case cfg of
  77            (NS _ _) ->
  78              -- We're only checking NS records, so report what we found.
  79              parallel (map report cdns)
  80            (MX _ _) ->
  81              return [()]
  82
  83     stopGlobalPool