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
  15 import Network.DNS (
  16   Domain,
  17   FileOrNumericHost(RCHostName),
  18   ResolvConf(resolvInfo),
  19   defaultResolvConf,
  20   makeResolvSeed,
  21   withResolver )
  22
  23 import CommandLine (Args(..), get_args)
  24 import DNS (
  25   LookupResult,
  26   lookupMX',
  27   lookupNS',
  28   normalize )
  29
  30 report :: (Domain, Maybe [Domain]) -> IO ()
  31 report (d, Nothing) =
  32   putStrLn $ "Domain " ++ (show d) ++ " not delegated."
  33 report (d, Just leftovers) =
  34   unless (null leftovers) $
  35     putStrLn $ "Domain " ++
  36                (show d) ++
  37                " delegates somewhere else: " ++
  38                (join " " (map show leftovers))
  39
  40 clean :: [Domain] -- ^ List of delegates, @ds@
  41       -> LookupResult
  42       -> LookupResult
  43 clean _ p@(_, Nothing) = p
  44 clean delgts (d, Just targets) =
  45   (d, Just $ targets \\ delgts)
  46
  47
  48
  49 main :: IO ()
  50 main = do
  51   cfg <- get_args
  52
  53   -- This reads stdin.
  54   input <- BS.getContents
  55
  56   -- Split the input on any whitespace characters.
  57   let raw_domains = BS.words input
  58
  59   -- Convert these to ByteStrings.
  60   let raw_delegates = map BS.pack (delegates cfg)
  61
  62   -- Normalize the given names and delegates
  63   let nrml_domains   = map normalize raw_domains
  64   let nrml_delegates = map normalize raw_delegates
  65
  66   let rc = case (server cfg) of
  67              Nothing -> defaultResolvConf
  68              Just s -> defaultResolvConf { resolvInfo = RCHostName s }
  69
  70   rs <- makeResolvSeed rc
  71
  72   let lookup_function = case cfg of
  73                           (NS _ _) -> lookupNS'
  74                           (MX _ _) -> lookupMX'
  75
  76   _ <- withResolver rs $ \resolver -> do
  77          -- Bad stuff happens if we try to run these lookups in parallel
  78          -- instead of the reports.
  79          records <- mapM (lookup_function resolver) nrml_domains
  80          let cleaned_records = map (clean nrml_delegates) records
  81          parallel (map report cleaned_records)
  82
  83   stopGlobalPool