Get it working for NS records.

diff --git a/haeres.cabal b/haeres.cabal
index 589670355fdcc70feaeec1305aa5d9a322ac9ca7..0183a294a7ac46fdccf114df147f01269a19af0b 100644 (file)
--- a/haeres.cabal
+++ b/haeres.cabal
@@ -18,7 +18,8 @@ executable haeres
     bytestring                  == 0.10.*,
     cmdargs                     == 0.10.*,
     dns                         >= 0.3.7,
     bytestring                  == 0.10.*,
     cmdargs                     == 0.10.*,
     dns                         >= 0.3.7,

-    MissingH                    == 1.2.*
+    MissingH                    == 1.2.*,
+    parallel-io                 == 0.3.*

 
   main-is:
     Main.hs
 
   main-is:
     Main.hs


@@ -37,6 +38,8 @@ executable haeres
     -fwarn-incomplete-record-updates
     -fwarn-monomorphism-restriction
     -fwarn-unused-do-bind
     -fwarn-incomplete-record-updates
     -fwarn-monomorphism-restriction
     -fwarn-unused-do-bind

+    -rtsopts
+    -threaded

     -optc-O3
     -optc-march=native
 
     -optc-O3
     -optc-march=native
 

diff --git a/src/CommandLine.hs b/src/CommandLine.hs
index 699ea97aceea436ce6abecbace894d43542984eb..acd097a7d3094b3a7fe757ae2b23495d81f92af9 100644 (file)
--- a/src/CommandLine.hs
+++ b/src/CommandLine.hs
@@ -2,7 +2,6 @@
 
 module CommandLine (
   Args(..),
 
 module CommandLine (
   Args(..),

-  Delegates(..),

   get_args
   )
 where
   get_args
   )
 where


@@ -32,16 +31,9 @@ server_help =
   "IP address of server to query " ++
   "(will use resolv.conf if not specified)"
 
   "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 =
 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
   deriving (Data, Show, Typeable)
 
 arg_spec :: Args

diff --git a/src/DNS.hs b/src/DNS.hs
new file mode 100644 (file)
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 142ace670cf62d4a83796c431185d5af2eeb891f..d425734c275404e24310edb650ac33c9b4fe0b67 100644 (file)
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,9 +1,15 @@
 module Main
 where
 
 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.List ((\\))

-import Data.String.Utils (join, splitWs)
+import Data.String.Utils (join)

 
 import Network.DNS (
   Domain,
 
 import Network.DNS (
   Domain,


@@ -12,12 +18,10 @@ import Network.DNS (
   defaultResolvConf,
   lookupNS,
   makeResolvSeed,
   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) =
 
 report :: (Domain, Maybe [Domain]) -> IO ()
 report (d, Nothing) =


@@ -30,24 +34,30 @@ report (d, Just leftovers) =
                   " delegates somewhere else: " ++
                   (join " " (map show 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 _ p@(_, Nothing) = p

-clean (Delegates ds') (d, Just targets) =
+clean ds (d, Just targets) =

   (d, Just $ targets \\ ds)
   (d, Just $ targets \\ ds)

-  where
-    ds = map BS.pack ds'
+

 
 main :: IO ()
 main = do
   cfg <- get_args
 
 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.
 
   -- 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
 
   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))
   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