From: Michael Orlitzky <michael@orlitzky.com>
Date: Tue, 8 Oct 2013 02:42:33 +0000 (-0400)
Subject: Bump dns dependency to 1.*, and update DNS module.
X-Git-Tag: 0.0.5
X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=fc58ff96c81d448e2c88376a2bc83cdfae1ccdc0;p=hath.git

Bump dns dependency to 1.*, and update DNS module.
Fix parallelism so that it actually happens.
Bump version to 0.0.5.
---

diff --git a/hath.cabal b/hath.cabal
index 5c2b9a2..e6f5395 100644
--- a/hath.cabal
+++ b/hath.cabal
@@ -1,5 +1,5 @@
 name:           hath
-version:        0.0.4
+version:        0.0.5
 cabal-version:  >= 1.8
 author:         Michael Orlitzky
 maintainer:	Michael Orlitzky <michael@orlitzky.com>
@@ -98,7 +98,7 @@ executable hath
   build-depends:
     base                        >= 4.6 && < 4.7,
     bytestring                  == 0.10.*,
-    dns                         == 0.3.*,
+    dns                         == 1.*,
     HUnit                       == 1.2.*,
     QuickCheck                  == 2.6.*,
     MissingH                    == 1.2.*,
@@ -155,7 +155,7 @@ test-suite testsuite
   build-depends:
     base                        >= 4.6 && < 4.7,
     bytestring                  == 0.10.*,
-    dns                         == 0.3.*,
+    dns                         == 1.*,
     HUnit                       == 1.2.*,
     QuickCheck                  == 2.6.*,
     MissingH                    == 1.2.*,
diff --git a/src/DNS.hs b/src/DNS.hs
index e1c4e51..041eeeb 100644
--- a/src/DNS.hs
+++ b/src/DNS.hs
@@ -1,10 +1,11 @@
 -- | Helpers to perform DNS queries.
 module DNS (
   Domain,
-  lookup_ptrs
-  )
+  PTRResult,
+  lookup_ptrs )
 where
 
+import Control.Concurrent.ParallelIO.Global ( parallel )
 import qualified  Data.ByteString.Char8 as BS (
   append,
   intercalate,
@@ -12,12 +13,16 @@ import qualified  Data.ByteString.Char8 as BS (
   split )
 import Network.DNS (
   Domain,
+  DNSError,
   ResolvConf(..),
   defaultResolvConf,
   lookupPTR,
   makeResolvSeed,
-  withResolver
-  )
+  withResolver )
+
+
+-- The return type of lookupPTR.
+type PTRResult = Either DNSError [Domain]
 
 
 -- | Convert the given IP address (as a ByteString) to the format
@@ -40,10 +45,13 @@ our_resolv_conf =
 
 -- | Takes a list of IP addresses (as ByteStrings) and performs
 --   reverse (PTR) lookups on each of them.
-lookup_ptrs :: [Domain] -> IO [Maybe [Domain]]
+lookup_ptrs :: [Domain] -> IO [PTRResult]
 lookup_ptrs ips = do
   rs <- makeResolvSeed our_resolv_conf
-  withResolver rs $ \resolver ->
-    mapM (lookupPTR resolver) in_addrs
+  let lookup' addr = withResolver rs $ \resolver ->
+                       lookupPTR resolver addr
+
+  parallel $ map lookup' in_addrs
+
   where
     in_addrs = map ip_to_in_addr_arpa ips
diff --git a/src/Main.hs b/src/Main.hs
index f567400..5afadcd 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,9 +1,7 @@
 module Main
 where
 
-import Control.Concurrent.ParallelIO.Global (
-  parallel,
-  stopGlobalPool )
+import Control.Concurrent.ParallelIO.Global ( stopGlobalPool )
 import Control.Monad (unless, when)
 import qualified Data.ByteString.Char8 as BS (intercalate, pack, unpack)
 import Data.List ((\\), intercalate)
@@ -32,7 +30,7 @@ import CommandLine (
   Mode(..),
   parse_errors,
   parse_mode )
-import DNS (Domain, lookup_ptrs)
+import DNS (Domain, PTRResult, lookup_ptrs)
 import ExitCodes ( exit_args_parse_failed, exit_invalid_cidr )
 import Octet ()
 
@@ -58,6 +56,7 @@ addr_barrier x = non_addr_char ++ x ++ non_addr_char
 --      max values.
 --   4. Join the regexes from step 3 with regexes matching periods.
 --   5. Stick an address boundary on either side of the result.
+--
 cidr_to_regex :: Cidr.Cidr -> String
 cidr_to_regex cidr =
     addr_barrier (intercalate "\\." [range1, range2, range3, range4])
@@ -155,18 +154,17 @@ main = do
       let addr_bytestrings = map (BS.pack . show) addrs
       ptrs <- lookup_ptrs addr_bytestrings
       let pairs = zip addr_bytestrings ptrs
-      _ <- parallel (map (putStrLn . show_pair) pairs)
-      return ()
+      mapM_ (putStrLn . show_pair) pairs
 
   stopGlobalPool
 
   where
-    show_pair :: (Domain, Maybe [Domain]) -> String
-    show_pair (s, mds) =
+    show_pair :: (Domain, PTRResult) -> String
+    show_pair (s, eds) =
       (BS.unpack s) ++ ": " ++ results
       where
         space = BS.pack " "
         results =
-          case mds of
-            Nothing -> ""
-            Just ds -> BS.unpack $ BS.intercalate space ds
+          case eds of
+            Left err -> "ERROR (" ++ (show err) ++ ")"
+            Right ds -> BS.unpack $ BS.intercalate space ds