From: Michael Orlitzky <michael@orlitzky.com>
Date: Wed, 24 Jul 2013 23:16:19 +0000 (-0400)
Subject: Get it working for NS records.
X-Git-Tag: 0.2.0~26
X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=70dffd6160208adf2c1c5746924c100cb0ffcb2e;p=haeredes.git

Get it working for NS records.
---

diff --git a/haeres.cabal b/haeres.cabal
index 5896703..0183a29 100644
--- a/haeres.cabal
+++ b/haeres.cabal
@@ -18,7 +18,8 @@ executable haeres
     bytestring                  == 0.10.*,
     cmdargs                     == 0.10.*,
     dns                         >= 0.3.7,
-    MissingH                    == 1.2.*
+    MissingH                    == 1.2.*,
+    parallel-io                 == 0.3.*
 
   main-is:
     Main.hs
@@ -37,6 +38,8 @@ executable haeres
     -fwarn-incomplete-record-updates
     -fwarn-monomorphism-restriction
     -fwarn-unused-do-bind
+    -rtsopts
+    -threaded
     -optc-O3
     -optc-march=native
 
diff --git a/src/CommandLine.hs b/src/CommandLine.hs
index 699ea97..acd097a 100644
--- a/src/CommandLine.hs
+++ b/src/CommandLine.hs
@@ -2,7 +2,6 @@
 
 module CommandLine (
   Args(..),
-  Delegates(..),
   get_args
   )
 where
@@ -32,16 +31,9 @@ server_help =
   "IP address of server to query " ++
   "(will use resolv.conf if not specified)"
 
-newtype Delegates =
-  Delegates { get_delegates :: [String] }
-  deriving (Data, Show, Typeable)
-
-instance Default Delegates where
-  def = Delegates []
-
 data Args =
-  NS { server :: Maybe String, delegates :: Delegates } |
-  MX { server :: Maybe String, delegates :: Delegates }
+  NS { server :: Maybe String, delegates :: [String] } |
+  MX { server :: Maybe String, delegates :: [String] }
   deriving (Data, Show, Typeable)
 
 arg_spec :: Args
diff --git a/src/DNS.hs b/src/DNS.hs
new file mode 100644
index 0000000..08d4f21
--- /dev/null
+++ b/src/DNS.hs
@@ -0,0 +1,29 @@
+module DNS (
+  normalize
+  )
+where
+
+import qualified Data.ByteString.Char8 as BS (
+  append,
+  last,
+  map,
+  pack )
+import Data.Char (toLower)
+import Network.DNS.Types (Domain)
+
+-- | Normalize the given name by lowercasing and appending a trailing
+--   dot (the root) if necessary.
+normalize :: Domain -> Domain
+normalize = normalize_case . normalize_root
+
+
+normalize_root :: Domain -> Domain
+normalize_root d
+  | BS.last d == '.' = d
+  | otherwise = d `BS.append` trailing_dot
+    where
+      trailing_dot = BS.pack "."
+
+
+normalize_case :: Domain -> Domain
+normalize_case = BS.map toLower
diff --git a/src/Main.hs b/src/Main.hs
index 142ace6..d425734 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,9 +1,15 @@
 module Main
 where
 
-import qualified Data.ByteString.Char8 as BS (pack)
+import Control.Concurrent.ParallelIO.Global (
+  parallel,
+  stopGlobalPool )
+import qualified Data.ByteString.Char8 as BS (
+  getContents,
+  pack,
+  words )
 import Data.List ((\\))
-import Data.String.Utils (join, splitWs)
+import Data.String.Utils (join)
 
 import Network.DNS (
   Domain,
@@ -12,12 +18,10 @@ import Network.DNS (
   defaultResolvConf,
   lookupNS,
   makeResolvSeed,
-  withResolver
-  )
+  withResolver )
 
-import System.IO (hGetContents, stdin)
-
-import CommandLine (Args(..), Delegates(..), get_args)
+import CommandLine (Args(..), get_args)
+import DNS (normalize)
 
 report :: (Domain, Maybe [Domain]) -> IO ()
 report (d, Nothing) =
@@ -30,24 +34,30 @@ report (d, Just leftovers) =
                   " delegates somewhere else: " ++
                   (join " " (map show leftovers))
 
-clean :: Delegates -> (Domain, Maybe [Domain]) -> (Domain, Maybe [Domain])
+clean :: [Domain] -- ^ List of delegates, @ds@
+      -> (Domain, Maybe [Domain]) -- ^ Pairs of (domain name, lookup result)
+      -> (Domain, Maybe [Domain])
 clean _ p@(_, Nothing) = p
-clean (Delegates ds') (d, Just targets) =
+clean ds (d, Just targets) =
   (d, Just $ targets \\ ds)
-  where
-    ds = map BS.pack ds'
+
 
 main :: IO ()
 main = do
   cfg <- get_args
-  print cfg
-  input <- hGetContents stdin
+
+  -- This reads stdin.
+  input <- BS.getContents
 
   -- Split the input on any whitespace characters.
-  let domains' = splitWs input
+  let raw_domains = BS.words input
+
+  -- Convert these to ByteStrings.
+  let raw_delegates = map BS.pack (delegates cfg)
 
-  -- Convert those Strings to ByteStrings
-  let domains  = map BS.pack domains'
+  -- Normalize the given names and delegates
+  let nrml_domains   = map normalize raw_domains
+  let nrml_delegates = map normalize raw_delegates
 
   let rc = case (server cfg) of
              Nothing -> defaultResolvConf
@@ -57,12 +67,17 @@ main = do
   withResolver rs $ \resolver -> do
     -- This function keeps the domain matches with its NS records.
     let lookupNS' = \d -> (lookupNS resolver d) >>= (return . ((,) d))
-    domains_ns <- mapM lookupNS' domains
-    let cdns = map (clean (delegates cfg)) domains_ns
-
-    case cfg of
-      (NS _ _) ->
-        -- We're only checking NS records, so report what we found.
-        mapM_ report cdns
-      (MX _ _) ->
-        print "Hello, world."
+
+    -- Bad stuff happens if we try to run these lookups in parallel
+    -- instead of the reports.
+    domains_ns <- mapM lookupNS' nrml_domains
+    let cdns = map (clean nrml_delegates) domains_ns
+
+    _ <- case cfg of
+           (NS _ _) ->
+             -- We're only checking NS records, so report what we found.
+             parallel (map report cdns)
+           (MX _ _) ->
+             return [()]
+
+    stopGlobalPool