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 5c2b9a20aca14e769a5a0b3863061a214be1c3c9..e6f53955df5171fc884c5f847d921f11e1ba2164 100644 (file)
--- a/hath.cabal
+++ b/hath.cabal
@@ -1,5 +1,5 @@
 name:           hath
 name:           hath

-version:        0.0.4
+version:        0.0.5

 cabal-version:  >= 1.8
 author:         Michael Orlitzky
 maintainer:    Michael Orlitzky <michael@orlitzky.com>
 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.*,
   build-depends:
     base                        >= 4.6 && < 4.7,
     bytestring                  == 0.10.*,

-    dns                         == 0.3.*,
+    dns                         == 1.*,

     HUnit                       == 1.2.*,
     QuickCheck                  == 2.6.*,
     MissingH                    == 1.2.*,
     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.*,
   build-depends:
     base                        >= 4.6 && < 4.7,
     bytestring                  == 0.10.*,

-    dns                         == 0.3.*,
+    dns                         == 1.*,

     HUnit                       == 1.2.*,
     QuickCheck                  == 2.6.*,
     MissingH                    == 1.2.*,
     HUnit                       == 1.2.*,
     QuickCheck                  == 2.6.*,
     MissingH                    == 1.2.*,

diff --git a/src/DNS.hs b/src/DNS.hs
index e1c4e51e5fa029e1bd367d6fb0e381143333057f..041eeeb52e2404b1d6951f3942cee600b8b28cc4 100644 (file)
--- a/src/DNS.hs
+++ b/src/DNS.hs
@@ -1,10 +1,11 @@
 -- | Helpers to perform DNS queries.
 module DNS (
   Domain,
 -- | Helpers to perform DNS queries.
 module DNS (
   Domain,

-  lookup_ptrs
-  )
+  PTRResult,
+  lookup_ptrs )

 where
 
 where
 

+import Control.Concurrent.ParallelIO.Global ( parallel )

 import qualified  Data.ByteString.Char8 as BS (
   append,
   intercalate,
 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,
   split )
 import Network.DNS (
   Domain,

+  DNSError,

   ResolvConf(..),
   defaultResolvConf,
   lookupPTR,
   makeResolvSeed,
   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
 
 
 -- | 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.
 
 -- | 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
 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
   where
     in_addrs = map ip_to_in_addr_arpa ips

diff --git a/src/Main.hs b/src/Main.hs
index f567400c1ac4080905b9a31700051bf91cb81d82..5afadcdfbc80e80fb1b4a2213afacce6fc836809 100644 (file)
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,9 +1,7 @@
 module Main
 where
 
 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)
 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 )
   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 ()
 
 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.
 --      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])
 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
       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
 
   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 =
       (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