Replace 'UserDomain' with 'Host' in the library.

[dead/harbl.git] / harbl / src / Network / DNS / RBL.hs

diff --git a/harbl/src/Network/DNS/RBL.hs b/harbl/src/Network/DNS/RBL.hs
new file mode 100644 (file)
index 0000000..c3268fd
--- /dev/null
+++ b/harbl/src/Network/DNS/RBL.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE DoAndIfThenElse #-}
+
+module Network.DNS.RBL (
+  Host,
+  Site,
+  host,
+  listing_message,
+  lookup_rbl,
+  sites )
+where
+
+import Data.ByteString.Char8 ( append, pack )
+import Data.IP ( IPv4 )
+import Data.List ( intercalate )
+import Data.Maybe ( catMaybes )
+import Network.DNS (
+  DNSError,
+  Resolver,
+  defaultResolvConf,
+  lookupA,
+  makeResolvSeed,
+  withResolver )
+
+import Network.DNS.RBL.Host ( Host, host, reverse_labels )
+import Network.DNS.RBL.IPv4Pattern ( addresses )
+import Network.DNS.RBL.Pretty ( Pretty(..) )
+import Network.DNS.RBL.Site ( Site(..), sites )
+
+
+
+-- | In most applications, you will want to know /why/ a host is
+--   blacklisted. This type stores those details: the host itself, the
+--   site on which the host was listed, and the return codes that we
+--   got back from the blacklist.
+data ListingDetails = ListingDetails Host Site [IPv4]
+
+
+-- | Create a nice \"error\" message from a host and the details of
+--   why it was listed.
+--
+listing_message :: ListingDetails -> String
+listing_message (ListingDetails h (Site d _ w) codes) =
+  "host " ++ (pretty_show h) ++ " " ++
+  "listed on " ++ (pretty_show d) ++ " " ++
+  "with return code(s) " ++ return_codes ++ " " ++
+  "having weight " ++ (pretty_show w)
+  where
+    return_codes :: String
+    return_codes = intercalate "," (map show codes)
+
+
+-- | This code is stolen from 'Network.DNS.lookupRDNS', which I'm
+--   pretty sure I wrote anyway.
+--
+dnslookup :: Resolver -> Host -> Host -> IO (Either DNSError [IPv4])
+dnslookup rlv rbl h = lookupA rlv dom
+  where
+    suffix = pack $ "." ++ (pretty_show rbl)
+    dom = (reverse_labels h) `append` suffix
+
+
+-- | See 'lookup_single'. The \"prime\" version here takes an
+--   additional @resolver@ argument for performance reasons.
+--
+lookup_single' :: Resolver
+               -> Host
+               -> Site
+               -> IO (Maybe ListingDetails)
+lookup_single' resolver h site@(Site d p _) = do
+  response <- dnslookup resolver d h
+  case response of
+    Left _ -> return Nothing -- Not listed, no error to report
+    Right ipv4s ->
+      case p of
+        -- No pattern given, but we got a hit.
+        Nothing -> return $ Just (ListingDetails h site ipv4s)
+        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 $ Just (ListingDetails h site ipv4s)
+          else return Nothing
+
+
+lookup_rbl :: [Site] -> Host -> IO [ListingDetails]
+lookup_rbl rbl_sites h = do
+  rs <- makeResolvSeed defaultResolvConf
+  withResolver rs $ \resolver -> do
+    results <- mapM (lookup_single' resolver h) rbl_sites
+    return $ catMaybes results