From c4d41b93ec02ff4dc762163441ebefb0324e6f07 Mon Sep 17 00:00:00 2001
From: Michael Orlitzky <michael@orlitzky.com>
Date: Thu, 9 Jul 2015 15:00:40 -0400
Subject: [PATCH] Add the Network.DNS.RBL.Host module.

---
 .ghci                       |   2 +
 harbl.cabal                 |   1 +
 src/Network/DNS/RBL.hs      | 111 +++++++-----------------------------
 src/Network/DNS/RBL/Host.hs |  73 ++++++++++++++++++++++++
 4 files changed, 97 insertions(+), 90 deletions(-)
 create mode 100644 src/Network/DNS/RBL/Host.hs

diff --git a/.ghci b/.ghci
index 53f4b20..dae4f7c 100644
--- a/.ghci
+++ b/.ghci
@@ -5,6 +5,7 @@
 :{
 :load src/Network/DNS/RBL.hs
   src/Network/DNS/RBL/Domain.hs
+  src/Network/DNS/RBL/Host.hs
   src/Network/DNS/RBL/IPv4Pattern.hs
   src/Network/DNS/RBL/Pretty.hs
   src/Network/DNS/RBL/Site.hs
@@ -12,6 +13,7 @@
 
 import Network.DNS.RBL
 import Network.DNS.RBL.Domain
+import Network.DNS.RBL.Host
 import Network.DNS.RBL.IPv4Pattern
 import Network.DNS.RBL.Pretty
 import Network.DNS.RBL.Site
diff --git a/harbl.cabal b/harbl.cabal
index 99fc090..6ae0bba 100644
--- a/harbl.cabal
+++ b/harbl.cabal
@@ -28,6 +28,7 @@ executable harbl
   other-modules:
     Network.DNS.RBL
     Network.DNS.RBL.Domain
+    Network.DNS.RBL.Host
     Network.DNS.RBL.IPv4Pattern
     Network.DNS.RBL.Pretty
     Network.DNS.RBL.Site
diff --git a/src/Network/DNS/RBL.hs b/src/Network/DNS/RBL.hs
index d9c232e..3c32e5d 100644
--- a/src/Network/DNS/RBL.hs
+++ b/src/Network/DNS/RBL.hs
@@ -1,11 +1,7 @@
 module Network.DNS.RBL ( lookup_single )
 where
 
-import qualified Data.ByteString.Char8 as BS (
-  append,
-  intercalate,
-  pack,
-  split )
+import Data.ByteString.Char8 ( append, pack )
 import Data.IP ( IPv4 )
 import Data.List ( intercalate )
 import Data.Maybe ( catMaybes )
@@ -18,14 +14,11 @@ import Network.DNS (
   withResolver )
 
 import Network.DNS.RBL.Domain ( UserDomain )
+import Network.DNS.RBL.Host ( Host, reverse_labels )
 import Network.DNS.RBL.IPv4Pattern ( addresses )
 import Network.DNS.RBL.Pretty ( Pretty(..) )
 import Network.DNS.RBL.Site ( Site(..), Weight(..) )
 
--- | A dumb wrapper around an IP address input as a 'String'.
---
-newtype Host = Host String
-instance Pretty Host where pretty_show (Host h) = h
 
 
 -- | In most applications, you will want to know /why/ a host is
@@ -53,84 +46,20 @@ listing_message host (ListingDetails (Site d _ w) codes) =
 --   pretty sure I wrote anyway.
 --
 dnslookup :: Resolver -> UserDomain -> Host -> IO (Either DNSError [IPv4])
-dnslookup rlv rbl (Host ip) = lookupA rlv dom
+dnslookup rlv rbl host = lookupA rlv dom
   where
-    -- ByteString constants.
-    dot = BS.pack "."
-    suffix = BS.pack $ "." ++ (pretty_show rbl)
-
-    octets = BS.split '.' (BS.pack ip)
-    reverse_ip = BS.intercalate dot (reverse octets)
-    dom = reverse_ip `BS.append` suffix
-
-
-
--- | Look up the given @host@ on a single RBL, and return the number
---   of \"points\" it scores. If the host is listed, it should score the
---   weight of the given blacklist. Otherwise, it scores zero.
---
-lookup_single :: Host -> Site -> IO Int
-lookup_single host site = do
-  rs <- makeResolvSeed defaultResolvConf
-  withResolver rs $ \resolver -> lookup_single' resolver host site
-
-
--- | See 'lookup_single'.
---
---   The \"prime\" version of this function takes a pre-existing
---   resolver as an argument for performance reasons.
---
-lookup_single' :: Resolver -> Host -> Site -> IO Int
-lookup_single' resolver host (Site d p (Weight w)) = do
-  response <- dnslookup resolver d host
-  case response of
-    Left _ -> return 0 -- Not listed
-    Right ipv4s ->
-      case p of
-        -- No pattern given, but we got a hit.
-        Nothing -> return w
-        Just pat -> do
-          let ipv4_strings = map show ipv4s
-          let codes = addresses pat
-          let hits = map (`elem` codes) ipv4_strings
-          if or hits -- if any of the returned addresses match the pattern
-          then return w
-          else return 0
-
-
--- | Look up the given @host@ on all of the white/blacklists contained
---   in @sites@. Return the total \"score\" for the @host@; that is,
---   the sum of the weights for each site whose pattern the host
---   matches.
---
-lookup_simple :: Host -> [Site] -> IO Int
-lookup_simple host sites = do
-  rs <- makeResolvSeed defaultResolvConf
-  withResolver rs $ \resolver -> do
-    results <- mapM (lookup_single' resolver host) sites
-    return $ sum results
+    suffix = pack $ "." ++ (pretty_show rbl)
+    dom = (reverse_labels host) `append` suffix
 
--- | Look up the given @host@ on all of the white/blacklists contained
---   in @sites@. If the results, multiplied by their weights, add up to
---   (at least) @threshold@, then @True@ is returned; that is, the
---   @host@ is \"listed\". Otherwise, @False@ is returned.
---
-lookup_threshold :: Host -> [Site] -> Int -> IO Bool
-lookup_threshold host sites threshold = do
-  score <- lookup_simple host sites
-  if score >= threshold
-  then return True
-  else return False
 
-
--- | See 'lookup_single_details'. The \"prime\" version here takes an
+-- | See 'lookup_single'. The \"prime\" version here takes an
 --   additional @resolver@ argument for performance reasons.
 --
-lookup_single_details' :: Resolver
-                       -> Host
-                       -> Site
-                       -> IO (Maybe ListingDetails)
-lookup_single_details' resolver host site@(Site d p (Weight w)) = do
+lookup_single' :: Resolver
+               -> Host
+               -> Site
+               -> IO (Maybe ListingDetails)
+lookup_single' resolver host site@(Site d p (Weight w)) = do
   response <- dnslookup resolver d host
   case response of
     Left _ -> return Nothing -- Not listed, no error to report
@@ -148,17 +77,19 @@ lookup_single_details' resolver host site@(Site d p (Weight w)) = do
 
 
 -- | Look up a single...
-lookup_single_details :: Host
-                      -> Site
-                      -> IO (Maybe ListingDetails)
-lookup_single_details host site = do
+lookup_single :: Host
+              -> Site
+              -> IO (Maybe ListingDetails)
+lookup_single host site = do
   rs <- makeResolvSeed defaultResolvConf
-  withResolver rs $ \resolver -> lookup_single_details' resolver host site
+  withResolver rs $ \resolver -> lookup_single' resolver host site
 
 
-lookup_details :: Host -> [Site] -> IO [ListingDetails]
-lookup_details host sites = do
+lookup :: Host -> [Site] -> IO [ListingDetails]
+lookup host sites = do
   rs <- makeResolvSeed defaultResolvConf
   withResolver rs $ \resolver -> do
-    results <- mapM (lookup_single_details' resolver host) sites
+    results <- mapM (lookup_single' resolver host) sites
     return $ catMaybes results
+
+
diff --git a/src/Network/DNS/RBL/Host.hs b/src/Network/DNS/RBL/Host.hs
new file mode 100644
index 0000000..ea7d4c8
--- /dev/null
+++ b/src/Network/DNS/RBL/Host.hs
@@ -0,0 +1,73 @@
+module Network.DNS.RBL.Host
+where
+
+import Data.ByteString.Char8 (
+  ByteString,
+  intercalate,
+  pack,
+  split )
+import qualified Network.DNS as DNS ( Domain )
+
+import Network.DNS.RBL.Domain ( UserDomain(..) )
+import Network.DNS.RBL.Pretty ( Pretty(..) )
+
+
+-- | A data type representing a host that we would like to look up on
+--   a blacklist. This can be either an IP address (for normal
+--   blacklists) or a domain name (for name-based blacklists).
+--
+--   Rather than make a distinction, we rely on the fact that we can
+--   parse all-digit \"domain names\". That is, we'll happily accept
+--   e.g. \"127.0.0.1\" as a name, and anything that isn't a valid IP
+--   address will implicitly be treated as a name and not an address.
+--
+newtype Host = Host UserDomain
+
+instance Pretty Host where pretty_show (Host d) = pretty_show d
+
+
+-- | Reverse the labels of this host in preparation for making a
+--   lookup (using the DNS library). We need to reverse the labels
+--   (the stuff between the dots) whether we're looking up a host or a
+--   name. The only tricky part here is that we need to turn an
+--   absolute 'UserDomain' into a relative one.
+--
+--   ==== _Examples_
+--
+--   >>> import Text.Parsec ( parse )
+--   >>> import Network.DNS.RBL.Domain ( user_domain )
+--
+--   >>> let (Right r) = parse user_domain "" "1.2.3.4"
+--   >>> let h = Host r
+--   >>> reverse_labels h
+--   "4.3.2.1"
+--
+--   >>> let (Right r) = parse user_domain "" "www.example.com"
+--   >>> let h = Host r
+--   >>> reverse_labels h
+--   "com.example.www"
+--
+--   Make sure absolute names are made relative:
+--
+--   >>> let (Right r) = parse user_domain "" "www.example.com."
+--   >>> let h = Host r
+--   >>> reverse_labels h
+--   "com.example.www"
+--
+reverse_labels :: Host -> DNS.Domain
+reverse_labels (Host h) = reversed
+  where
+    -- | It's possible that we are given an absolute domain name to
+    --   look up. This is legit; say I want to look up
+    --   \"www.example.com.\" That's fine, but before we make the
+    --   actual query we'll need to make it relative and then append
+    --   the DNSBL's suffix to it.
+    relative_host_string :: String
+    relative_host_string =
+      case h of
+        (UserDomainRelative _) -> pretty_show h
+        (UserDomainAbsolute d) -> pretty_show d
+
+    dot = pack "."
+    labels = split '.' (pack relative_host_string)
+    reversed = intercalate dot (reverse labels)
-- 
2.43.2