From: Michael Orlitzky <michael@orlitzky.com>
Date: Wed, 24 Jul 2013 14:37:33 +0000 (-0400)
Subject: First iteration that does anything.
X-Git-Tag: 0.2.0~27
X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=825753e2731b8491d93d9f2d66b457fe31b1c763;p=haeredes.git

First iteration that does anything.
---

diff --git a/haeres.cabal b/haeres.cabal
index c36a31b..5896703 100644
--- a/haeres.cabal
+++ b/haeres.cabal
@@ -14,7 +14,11 @@ build-type:     Simple
 
 executable haeres
   build-depends:
-    base                        == 4.*
+    base                        == 4.*,
+    bytestring                  == 0.10.*,
+    cmdargs                     == 0.10.*,
+    dns                         >= 0.3.7,
+    MissingH                    == 1.2.*
 
   main-is:
     Main.hs
diff --git a/src/CommandLine.hs b/src/CommandLine.hs
new file mode 100644
index 0000000..699ea97
--- /dev/null
+++ b/src/CommandLine.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module CommandLine (
+  Args(..),
+  Delegates(..),
+  get_args
+  )
+where
+
+import System.Console.CmdArgs
+
+-- Get the version from Cabal.
+import Paths_haeres (version)
+import Data.Version (showVersion)
+
+ns_description :: String
+ns_description =
+  "Confirm delegation of NS records. " ++
+  "This is the default mode."
+
+mx_description :: String
+mx_description = "Confirm delegation of MX records."
+
+program_name :: String
+program_name = "haeres"
+
+my_summary :: String
+my_summary = program_name ++ "-" ++ (showVersion version)
+
+server_help :: String
+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 }
+  deriving (Data, Show, Typeable)
+
+arg_spec :: Args
+arg_spec =
+  modes [ns &= auto, mx]
+    &= program program_name
+    &= summary my_summary
+    &= helpArg [explicit,
+                name "help",
+                name "h",
+                groupname "Common flags"]
+    &= versionArg [explicit,
+                   name "version",
+                   name "v",
+                   groupname "Common flags"]
+  where
+    -- The repetition here is necessary, some Template Haskell magic
+    -- going on.
+    ns :: Args
+    ns = NS {
+           server = def
+                  &= groupname "Common flags"
+                  &= typ "IP"
+                  &= help server_help,
+
+           delegates = def
+                     &= args
+                     &= typ "DELEGATES" }
+
+            &= details [ns_description]
+
+    mx :: Args
+    mx = MX {
+           server = def
+                 &= groupname "Common flags"
+                 &= typ "IP"
+                 &= help server_help,
+
+           delegates = def
+                    &= args
+                    &= typ "DELEGATES" }
+
+            &= details [mx_description]
+
+get_args :: IO Args
+get_args = cmdArgs arg_spec
diff --git a/src/Main.hs b/src/Main.hs
index b141e30..142ace6 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,6 +1,68 @@
 module Main
 where
 
+import qualified Data.ByteString.Char8 as BS (pack)
+import Data.List ((\\))
+import Data.String.Utils (join, splitWs)
+
+import Network.DNS (
+  Domain,
+  FileOrNumericHost(RCHostName),
+  ResolvConf(resolvInfo),
+  defaultResolvConf,
+  lookupNS,
+  makeResolvSeed,
+  withResolver
+  )
+
+import System.IO (hGetContents, stdin)
+
+import CommandLine (Args(..), Delegates(..), get_args)
+
+report :: (Domain, Maybe [Domain]) -> IO ()
+report (d, Nothing) =
+  putStrLn $ "Domain " ++ (show d) ++ " not delegated."
+report (d, Just leftovers) =
+  if null leftovers
+  then return ()
+  else putStrLn $ "Domain " ++
+                  (show d) ++
+                  " delegates somewhere else: " ++
+                  (join " " (map show leftovers))
+
+clean :: Delegates -> (Domain, Maybe [Domain]) -> (Domain, Maybe [Domain])
+clean _ p@(_, Nothing) = p
+clean (Delegates ds') (d, Just targets) =
+  (d, Just $ targets \\ ds)
+  where
+    ds = map BS.pack ds'
+
 main :: IO ()
 main = do
-  putStrLn "Hello, World."
+  cfg <- get_args
+  print cfg
+  input <- hGetContents stdin
+
+  -- Split the input on any whitespace characters.
+  let domains' = splitWs input
+
+  -- Convert those Strings to ByteStrings
+  let domains  = map BS.pack domains'
+
+  let rc = case (server cfg) of
+             Nothing -> defaultResolvConf
+             Just s -> defaultResolvConf { resolvInfo = RCHostName s }
+
+  rs <- makeResolvSeed rc
+  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."