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

Restructure everything to support a separate executable.
Get a basis stub executable working.

diff --git a/harbl-cli/src/CommandLine.hs b/harbl-cli/src/CommandLine.hs
new file mode 100644 (file)
index 0000000..a3481fe
--- /dev/null
+++ b/harbl-cli/src/CommandLine.hs
@@ -0,0 +1,62 @@
+module CommandLine ( get_args )
+where
+
+import System.Console.CmdArgs (
+  (&=),
+  args,
+  cmdArgs,
+  def,
+  details,
+  help,
+  program,
+  summary,
+  typ )
+
+-- This let's us get the version from Cabal.
+import Paths_harbl ( version )
+import Data.Version ( showVersion )
+
+import Hosts ()
+import Lists ()
+import OptionalConfiguration ( OptionalConfiguration(..) )
+
+-- | The description of the program, displayed as part of the help.
+description :: String
+description = "Perform black- and white-list lookups on hosts."
+
+
+-- | The name of this program.
+program_name :: String
+program_name = "harbl"
+
+
+-- | A summary string output as part of the help.
+my_summary :: String
+my_summary = program_name ++ "-" ++ (showVersion version)
+
+
+-- | A description of the "daemonize" option.
+lists_help :: String
+lists_help =
+  "A list of RBLs to check. See the manual for advanced syntax."
+
+
+-- | A data structure representing the possible command-line
+--   options. The CmdArgs library is doing heavy magic beneath the
+--   hood here.
+--
+arg_spec :: OptionalConfiguration
+arg_spec =
+  OptionalConfiguration {
+    hosts = def &= typ "HOSTS" &= args,
+    lists = def &= typ "RBLs"  &= help lists_help }
+  &= program program_name
+  &= summary my_summary
+  &= details [description]
+
+
+-- | A convenience function; our only export. Meant to be used in
+--   'main' to retrieve the command-line arguments.
+--
+get_args :: IO OptionalConfiguration
+get_args = cmdArgs arg_spec

diff --git a/harbl-cli/src/Configuration.hs b/harbl-cli/src/Configuration.hs
new file mode 100644 (file)
index 0000000..64adc7e
--- /dev/null
+++ b/harbl-cli/src/Configuration.hs
@@ -0,0 +1,48 @@
+-- | This module defines the 'Configuration' type, which is just a
+--   wrapper around all of the configuration options we accept on the
+--   command line.
+--
+module Configuration (
+  Configuration(..),
+  merge_optional )
+where
+
+import System.Console.CmdArgs.Default ( Default(..) )
+
+import qualified OptionalConfiguration as OC (
+  OptionalConfiguration(..) )
+import Hosts ( Hosts(..) )
+import Lists ( Lists(..) )
+
+
+-- | The main configuration data type. This will be passed to most of
+--   the important functions once it has been created.
+--
+data Configuration =
+  Configuration {
+    hosts  :: Hosts,
+    lists  :: Lists }
+    deriving (Show)
+
+
+-- | A Configuration with all of its fields set to their default
+--   values.
+--
+instance Default Configuration where
+  def = Configuration { hosts = def, lists = def }
+
+
+-- | Merge a 'Configuration' with an 'OptionalConfiguration'. This is
+--   more or less the Monoid instance for 'OptionalConfiguration', but
+--   since the two types are different, we have to repeat ourselves.
+--
+merge_optional :: Configuration
+               -> OC.OptionalConfiguration
+               -> Configuration
+merge_optional cfg opt_cfg =
+  Configuration all_hosts all_lists
+  where
+    all_hosts =
+      Hosts $ (get_hosts $ hosts cfg) ++ (get_hosts $ OC.hosts opt_cfg)
+    all_lists =
+      Lists $ (get_lists $ lists cfg) ++ (get_lists $ OC.lists opt_cfg)

diff --git a/harbl-cli/src/ExitCodes.hs b/harbl-cli/src/ExitCodes.hs
new file mode 100644 (file)
index 0000000..472ea15
--- /dev/null
+++ b/harbl-cli/src/ExitCodes.hs
@@ -0,0 +1,32 @@
+-- | All exit codes that the program can return (excepting
+--   ExitSuccess).
+--
+module ExitCodes (
+  exit_no_hosts,
+  exit_no_lists,
+  exit_unparseable_host,
+  exit_unparseable_list )
+where
+
+-- | No hosts were given on the command-line or in a config file.
+--
+exit_no_hosts :: Int
+exit_no_hosts = 1
+
+
+-- | No lists were given on the command-line or in a config file.
+--
+exit_no_lists :: Int
+exit_no_lists = 2
+
+
+-- | The user gave us an RBL we couldn't parse.
+--
+exit_unparseable_list :: Int
+exit_unparseable_list = 3
+
+
+-- | The user gave us a host we couldn't parse.
+--
+exit_unparseable_host :: Int
+exit_unparseable_host = 4

diff --git a/harbl-cli/src/Hosts.hs b/harbl-cli/src/Hosts.hs
new file mode 100644 (file)
index 0000000..020484d
--- /dev/null
+++ b/harbl-cli/src/Hosts.hs
@@ -0,0 +1,47 @@
+-- | A newtype around a list of Strings which represent hosts to look up.
+--   This is all to avoid an orphan instance of 'Configured' for
+--   [String] if we had defined one in e.g. 'OptionalConfiguration'.
+--
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Hosts ( Hosts(..) )
+where
+
+-- DC is needed only for the DCT.Configured instance of String.
+import qualified Data.Configurator as DC()
+import qualified Data.Configurator.Types as DCT (
+  Configured,
+  Value( List ),
+  convert )
+import Data.Data ( Data )
+import System.Console.CmdArgs.Default ( Default(..) )
+import Data.Typeable ( Typeable )
+
+
+-- | A (wrapper around a) list of hosts.
+--
+newtype Hosts =
+  Hosts { get_hosts :: [String] }
+    deriving (Data, Show, Typeable)
+
+
+-- | The default list of hosts. It's empty.
+--
+instance Default Hosts where def = Hosts []
+
+instance DCT.Configured Hosts where
+  -- | This allows us to read a Hosts object out of a Configurator
+  --   config file. By default Configurator wouldn't know what to do,
+  --   so we have to tell it that we expect a list, and if that list
+  --   has strings in it, we can apply the Hosts constructor to
+  --   it.
+  convert (DCT.List xs) =
+    -- mapM gives us a Maybe [String] here.
+    fmap Hosts (mapM convert_string xs)
+    where
+      convert_string :: DCT.Value -> Maybe String
+      convert_string = DCT.convert
+
+  -- If we read anything other than a list of values out of the file,
+  -- fail.
+  convert _ = Nothing

diff --git a/harbl-cli/src/Lists.hs b/harbl-cli/src/Lists.hs
new file mode 100644 (file)
index 0000000..8edb167
--- /dev/null
+++ b/harbl-cli/src/Lists.hs
@@ -0,0 +1,47 @@
+-- | A newtype around a list of Strings representing blacklists.
+--   This is all to avoid an orphan instance of 'Configured' for
+--   [String] if we had defined one in e.g. 'OptionalConfiguration'.
+--
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Lists ( Lists(..) )
+where
+
+-- DC is needed only for the DCT.Configured instance of String.
+import qualified Data.Configurator as DC()
+import qualified Data.Configurator.Types as DCT (
+  Configured,
+  Value( List ),
+  convert )
+import Data.Data ( Data )
+import System.Console.CmdArgs.Default ( Default(..) )
+import Data.Typeable ( Typeable )
+
+
+-- | A (wrapper around a) list of blacklists.
+--
+newtype Lists =
+  Lists { get_lists :: [String] }
+    deriving (Data, Show, Typeable)
+
+
+-- | The default list of white/blacklists. It's empty.
+--
+instance Default Lists where def = Lists []
+
+instance DCT.Configured Lists where
+  -- | This allows us to read a 'Lists' object out of a Configurator
+  --   config file. By default Configurator wouldn't know what to do,
+  --   so we have to tell it that we expect a list, and if that list
+  --   has strings in it, we can apply the Lists constructor to
+  --   it.
+  convert (DCT.List xs) =
+    -- mapM gives us a Maybe [String] here.
+    fmap Lists (mapM convert_string xs)
+    where
+      convert_string :: DCT.Value -> Maybe String
+      convert_string = DCT.convert
+
+  -- If we read anything other than a list of values out of the file,
+  -- fail.
+  convert _ = Nothing

diff --git a/harbl-cli/src/Main.hs b/harbl-cli/src/Main.hs
new file mode 100644 (file)
index 0000000..d2ac8d2
--- /dev/null
+++ b/harbl-cli/src/Main.hs
@@ -0,0 +1,82 @@
+module Main ( main )
+where
+
+import Control.Monad ( liftM, when )
+import Data.Monoid ( (<>) )
+import Text.Parsec ( ParseError, parse )
+import System.Console.CmdArgs ( def )
+import System.Exit ( exitWith, ExitCode (ExitFailure) )
+import System.IO ( hPutStrLn, stderr )
+
+import CommandLine ( get_args )
+import Configuration ( Configuration(..), merge_optional )
+import ExitCodes (
+  exit_no_hosts,
+  exit_no_lists,
+  exit_unparseable_host,
+  exit_unparseable_list )
+import Hosts ( Hosts(..) )
+import Lists ( Lists(..) )
+import qualified OptionalConfiguration as OC ( from_rc )
+import Network.DNS.RBL (
+  Host,
+  Site,
+  host,
+  listing_message,
+  lookup_rbl,
+  sites )
+
+
+-- | The 'concatMapM' function generalizes 'concatMap' to arbitrary monads.
+--   See e.g. <https://ghc.haskell.org/trac/ghc/ticket/2042>
+concatMapM        :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
+concatMapM f xs   =  liftM concat (mapM f xs)
+
+-- | Parse a list of RBL sites from the user's input. If he was nice,
+--   he would have given us a list of individual RBLs. But we also
+--   handle the case where a big comma-separated string is given to
+--   us.
+--
+parse_lists :: Lists -> Either ParseError [Site]
+parse_lists (Lists ls) = concatMapM (parse sites "") ls
+
+-- | Parse a list of hosts from the user's input. Each one should be
+--   parseable as a 'Host'.
+--
+parse_hosts :: Hosts -> Either ParseError [Host]
+parse_hosts (Hosts hs) = mapM (parse host "") hs
+
+
+main :: IO ()
+main = do
+  rc_cfg <- OC.from_rc
+  cmd_cfg <- get_args
+
+  -- Merge the config file options with the command-line ones,
+  -- prefering the command-line ones.
+  let opt_config = rc_cfg <> cmd_cfg
+
+  -- Update a default config with any options that have been set in
+  -- either the config file or on the command-line.  We initialize
+  -- logging before the missing parameter checks below so that we can
+  -- log the errors.
+  let cfg = (def :: Configuration) `merge_optional` opt_config
+
+  when (null $ get_hosts $ hosts cfg) $
+    exitWith (ExitFailure exit_no_hosts)
+
+  when (null $ get_lists $ lists cfg) $
+    exitWith (ExitFailure exit_no_lists)
+
+  case (parse_lists $ lists cfg) of
+    Left e -> do
+      hPutStrLn stderr (show e)
+      exitWith (ExitFailure exit_unparseable_list)
+    Right ls -> do
+      case (parse_hosts $ hosts cfg) of
+        Left e -> do
+          hPutStrLn stderr (show e)
+          exitWith (ExitFailure exit_unparseable_host)
+        Right hs -> do
+          listings <- concatMapM (lookup_rbl ls) hs
+          mapM_ (putStrLn . listing_message) listings

diff --git a/harbl-cli/src/OptionalConfiguration.hs b/harbl-cli/src/OptionalConfiguration.hs
new file mode 100644 (file)
index 0000000..35ca7d4
--- /dev/null
+++ b/harbl-cli/src/OptionalConfiguration.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+-- | An OptionalConfiguration is just like a 'Configuration', except
+--   all of its fields are optional. The user can set options in two
+--   places: the command-line, and a configuration file. Obviously if
+--   a parameter is set in one place, it doesn't need to be set in the
+--   other. Thus, the latter needs to be optional.
+--
+module OptionalConfiguration (
+  OptionalConfiguration(..),
+  from_rc )
+where
+
+-- System imports.
+import qualified Data.Configurator as DC (
+  Worth(Optional),
+  load,
+  lookup )
+import Data.Data ( Data )
+import Data.Maybe ( fromMaybe )
+import Data.Monoid ( Monoid(..) )
+import Data.Typeable ( Typeable )
+import Paths_harbl ( getSysconfDir )
+import System.Console.CmdArgs.Default ( Default(..) )
+import System.Directory ( getHomeDirectory )
+import System.FilePath ( (</>) )
+import System.IO.Error ( catchIOError )
+import System.IO ( hPutStrLn, stderr )
+
+-- Local imports.
+import Hosts ( Hosts(..) )
+import Lists ( Lists(..) )
+
+
+-- | The same as 'Configuration', except everything is optional. It's
+--   easy to merge two of these by simply dropping the 'Nothing's in
+--   favor of the 'Just's. The 'xml_files' are left un-maybed so that
+--   cmdargs can parse more than one of them.
+--
+data OptionalConfiguration =
+  OptionalConfiguration {
+    hosts :: Hosts,
+    lists :: Lists }
+    deriving (Show, Data, Typeable)
+
+
+-- | The Monoid instance for these lets us \"combine\" two
+--   OptionalConfigurations. The \"combine\" operation that we'd like to
+--   perform is, essentially, to mash them together. So if we have two
+--   OptionalConfigurations, each half full, we could combine them
+--   into one big one.
+--
+--   This is used to merge command-line and config-file settings.
+--
+instance Monoid OptionalConfiguration where
+  -- | An empty OptionalConfiguration.
+  mempty = OptionalConfiguration (Hosts []) (Lists [])
+
+
+  -- | Combine @cfg1@ and @cfg2@, giving precedence to @cfg2@.
+  --   XML files can only be specified on the command-line, so we
+  --   just join them together here.
+  cfg1 `mappend` cfg2 =
+    OptionalConfiguration all_hosts all_lists
+    where
+      all_hosts = Hosts $ (get_hosts $ hosts cfg1) ++ (get_hosts $ hosts cfg2)
+      all_lists = Lists $ (get_lists $ lists cfg1) ++ (get_lists $ lists cfg2)
+
+
+
+-- | Obtain an OptionalConfiguration from harblrc in either the global
+--   configuration directory or the user's home directory. The one in
+--   $HOME is prefixed by a dot so that it is hidden.
+--
+--   We make an attempt at cross-platform compatibility; we will try
+--   to find the correct directory even on Windows. But if the calls
+--   to getHomeDirectory/getSysconfDir fail for whatever reason, we
+--   fall back to using the Unix-specific /etc and $HOME.
+--
+from_rc :: IO OptionalConfiguration
+from_rc = do
+  etc  <- catchIOError getSysconfDir (\e -> do
+                                        hPutStrLn stderr (show e)
+                                        return "/etc")
+  home <- catchIOError getHomeDirectory (\e -> do
+                                           hPutStrLn stderr (show e)
+                                           return "$(HOME)")
+  let global_config_path = etc </> "harblrc"
+  let user_config_path = home </> ".harblrc"
+  cfg <- DC.load [ DC.Optional global_config_path,
+                   DC.Optional user_config_path ]
+  cfg_lists <- DC.lookup cfg "lists"
+  let cfg_hosts = Hosts [] -- This won't be in the config file.
+  return $ OptionalConfiguration cfg_hosts (fromMaybe def cfg_lists)

diff --git a/harbl.cabal b/harbl.cabal
index 6ae0bba189d9020e083abd14fa14b087b6aff60a..8f4401fd7e0c823baba01f34fd49ba472e2110fd 100644 (file)
--- a/harbl.cabal
+++ b/harbl.cabal
@@ -13,20 +13,20 @@ description:
   Provides utility functions for performing blacklist lookups.
 
 
-executable harbl
+library
   build-depends:
     base                        >= 4.6 && < 5,
+    bytestring                  >= 0.9,
     dns                         >= 2,
     iproute                     >= 1.4,
     parsec                      >= 3,
     tasty                       >= 0.8,
     tasty-hunit                 >= 0.8
 
-  main-is:
-    Main.hs
+  exposed-modules:
+    Network.DNS.RBL
 
   other-modules:
-    Network.DNS.RBL
     Network.DNS.RBL.Domain
     Network.DNS.RBL.Host
     Network.DNS.RBL.IPv4Pattern
@@ -34,7 +34,42 @@ executable harbl
     Network.DNS.RBL.Site
 
   hs-source-dirs:
-    src/
+    harbl/src/
+
+  ghc-options:
+    -Wall
+    -fwarn-hi-shadowing
+    -fwarn-missing-signatures
+    -fwarn-name-shadowing
+    -fwarn-orphans
+    -fwarn-type-defaults
+    -fwarn-tabs
+    -fwarn-incomplete-record-updates
+    -fwarn-monomorphism-restriction
+    -fwarn-unused-do-bind
+    -O2
+
+  ghc-prof-options:
+    -prof
+    -fprof-auto
+    -fprof-cafs
+
+
+executable harbl
+  build-depends:
+    base                        >= 4.6 && < 5,
+    cmdargs                     >= 0.10.6,
+    configurator                >= 0.2,
+    directory,
+    filepath,
+    harbl,
+    parsec                      >= 3
+
+  main-is:
+    Main.hs
+
+  hs-source-dirs:
+    harbl-cli/src/
 
   ghc-options:
     -Wall
@@ -61,6 +96,7 @@ test-suite testsuite
   main-is: TestSuite.hs
   build-depends:
     base                        >= 4.6 && < 5,
+    bytestring                  >= 0.9,
     dns                         >= 2,
     iproute                     >= 1.4,
     parsec                      >= 3,

diff --git a/src/Network/DNS/RBL.hs b/harbl/src/Network/DNS/RBL.hs
similarity index 55%
rename from src/Network/DNS/RBL.hs
rename to harbl/src/Network/DNS/RBL.hs
index 3c32e5d97b990d654b92bf1e5ad40279b529c65e..c3268fd894ac8c1f3f151393f0739a63eb012adf 100644 (file)
--- a/src/Network/DNS/RBL.hs
+++ b/harbl/src/Network/DNS/RBL.hs
@@ -1,4 +1,12 @@
-module Network.DNS.RBL ( lookup_single )
+{-# LANGUAGE DoAndIfThenElse #-}
+
+module Network.DNS.RBL (
+  Host,
+  Site,
+  host,
+  listing_message,
+  lookup_rbl,
+  sites )
 where
 
 import Data.ByteString.Char8 ( append, pack )
@@ -13,27 +21,26 @@ import Network.DNS (
   makeResolvSeed,
   withResolver )
 
-import Network.DNS.RBL.Domain ( UserDomain )
-import Network.DNS.RBL.Host ( Host, reverse_labels )
+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(..), Weight(..) )
+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 site on which
---   the host was listed, and the return codes that we got back from
---   the blacklist.
-data ListingDetails = ListingDetails Site [IPv4]
+--   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 :: Host -> ListingDetails -> String
-listing_message host (ListingDetails (Site d _ w) codes) =
-  "host " ++ (pretty_show host) ++ " " ++
+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)
@@ -45,11 +52,11 @@ listing_message host (ListingDetails (Site d _ w) codes) =
 -- | This code is stolen from 'Network.DNS.lookupRDNS', which I'm
 --   pretty sure I wrote anyway.
 --
-dnslookup :: Resolver -> UserDomain -> Host -> IO (Either DNSError [IPv4])
-dnslookup rlv rbl host = lookupA rlv dom
+dnslookup :: Resolver -> Host -> Host -> IO (Either DNSError [IPv4])
+dnslookup rlv rbl h = lookupA rlv dom
   where
     suffix = pack $ "." ++ (pretty_show rbl)
-    dom = (reverse_labels host) `append` suffix
+    dom = (reverse_labels h) `append` suffix
 
 
 -- | See 'lookup_single'. The \"prime\" version here takes an
@@ -59,37 +66,26 @@ lookup_single' :: Resolver
                -> Host
                -> Site
                -> IO (Maybe ListingDetails)
-lookup_single' resolver host site@(Site d p (Weight w)) = do
-  response <- dnslookup resolver d host
+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 site ipv4s)
+        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 site ipv4s)
+          then return $ Just (ListingDetails h site ipv4s)
           else return Nothing
 
 
--- | Look up a single...
-lookup_single :: Host
-              -> Site
-              -> IO (Maybe ListingDetails)
-lookup_single host site = do
-  rs <- makeResolvSeed defaultResolvConf
-  withResolver rs $ \resolver -> lookup_single' resolver host site
-
-
-lookup :: Host -> [Site] -> IO [ListingDetails]
-lookup host sites = do
+lookup_rbl :: [Site] -> Host -> IO [ListingDetails]
+lookup_rbl rbl_sites h = do
   rs <- makeResolvSeed defaultResolvConf
   withResolver rs $ \resolver -> do
-    results <- mapM (lookup_single' resolver host) sites
+    results <- mapM (lookup_single' resolver h) rbl_sites
     return $ catMaybes results
-
-

diff --git a/src/Network/DNS/RBL/Domain.hs b/harbl/src/Network/DNS/RBL/Domain.hs
similarity index 90%
rename from src/Network/DNS/RBL/Domain.hs
rename to harbl/src/Network/DNS/RBL/Domain.hs
index 73a69884f826945c1aacca3b118c6c7a389e6693..75170a7675bf09ab3c509d41b1ada58b16fbac05 100644 (file)
--- a/src/Network/DNS/RBL/Domain.hs
+++ b/harbl/src/Network/DNS/RBL/Domain.hs
@@ -15,8 +15,8 @@
 --   (octets).
 --
 module Network.DNS.RBL.Domain (
-  UserDomain(..),
-  user_domain )
+  Domain,
+  domain )
 where
 
 import Data.Char ( toLower )
@@ -639,8 +639,6 @@ subdomain_has_equal_neighbors s =
 --
 --   We let the 'Domain' type remain true to those RFCs, even though
 --   they don't support an absolute domain name of e.g. a single dot.
---   We have one more data type 'UserDomain' which handles the possibility
---   of an absolute path.
 --
 data Domain =
   DomainName Subdomain |
@@ -719,76 +717,3 @@ domain = try parse_subdomain <|> parse_empty
 
     parse_empty :: Parser Domain
     parse_empty = string "" >> return DomainRoot
-
-
-
--- * User domains
-
--- | This type helps clarify some murkiness in the DNS \"domain\" name
---   specification. In RFC1034, it is acknowledged that a domain name
---   input with a trailing \".\" will represent an absolute domain
---   name (i.e. with respect to the DNS root). However, the grammar in
---   RFC1035 disallows a trailing dot.
---
---   This makes some sense: within the DNS, everything knows its
---   position in the tree. The relative/absolute distinction only
---   makes sense on the client side, where a user's resolver might
---   decide to append some suffix to a relative
---   request. Unfortunately, that's where we live. So we have to deal
---   with the possibility of having a trailing dot at the end of any
---   domain name.
---
-data UserDomain =
-  UserDomainRelative Domain |
-  UserDomainAbsolute Domain
-  deriving (Eq, Show)
-
-instance Pretty UserDomain where
-  pretty_show (UserDomainRelative d) = pretty_show d
-  pretty_show (UserDomainAbsolute d) = (pretty_show d) ++ "."
-
-
--- | Parse a 'UserDomain'. This is what we'll be using to read user
---   input, since it supports both relative and absolute domain names
---   (unlike the implicitly-absolute 'Domain').
---
---   ==== _Examples_
---
---   >>> import Text.Parsec ( parse, parseTest )
---
---   We can really parse the root now!
---
---   >>> parseTest user_domain "."
---   UserDomainAbsolute DomainRoot
---
---   But multiple dots aren't (only the first):
---
---   >>> pretty_print $ parse user_domain "" ".."
---   .
---
---   We can also optionally have a trailing dot at the end of a
---   non-empty name:
---
---   >>>  pretty_print $ parse user_domain "" "www.example.com"
---   www.example.com
---
---   >>>  pretty_print $ parse user_domain "" "www.example.com."
---   www.example.com.
---
---   A \"relative root\" can also be parsed, letting the user's
---   resolver deal with it:
---
---   >>> parseTest user_domain ""
---   UserDomainRelative DomainRoot
---
-user_domain :: Parser UserDomain
-user_domain = try absolute <|> relative
-  where
-    absolute :: Parser UserDomain
-    absolute = do
-      d <- domain
-      _ <- char '.'
-      return $ UserDomainAbsolute d
-
-    relative :: Parser UserDomain
-    relative = fmap UserDomainRelative domain

diff --git a/harbl/src/Network/DNS/RBL/Host.hs b/harbl/src/Network/DNS/RBL/Host.hs
new file mode 100644 (file)
index 0000000..93deeb8
--- /dev/null
+++ b/harbl/src/Network/DNS/RBL/Host.hs
@@ -0,0 +1,130 @@
+module Network.DNS.RBL.Host
+where
+
+import Data.ByteString.Char8 (
+  intercalate,
+  pack,
+  split )
+import qualified Network.DNS as DNS ( Domain )
+import Text.Parsec (
+  (<|>),
+  char,
+  try )
+import Text.Parsec.String ( Parser )
+
+import Network.DNS.RBL.Domain ( Domain, domain )
+import Network.DNS.RBL.Pretty ( Pretty(..) )
+
+
+-- | This type helps clarify some murkiness in the DNS \"domain\" name
+--   specification. In RFC1034, it is acknowledged that a domain name
+--   input with a trailing \".\" will represent an absolute domain
+--   name (i.e. with respect to the DNS root). However, the grammar in
+--   RFC1035 disallows a trailing dot.
+--
+--   This makes some sense: within the DNS, everything knows its
+--   position in the tree. The relative/absolute distinction only
+--   makes sense on the client side, where a user's resolver might
+--   decide to append some suffix to a relative
+--   request. Unfortunately, that's where we live. So we have to deal
+--   with the possibility of having a trailing dot at the end of any
+--   domain name.
+--
+data Host =
+  HostRelative Domain |
+  HostAbsolute Domain
+  deriving (Eq, Show)
+
+instance Pretty Host where
+  pretty_show (HostRelative d) = pretty_show d
+  pretty_show (HostAbsolute d) = (pretty_show d) ++ "."
+
+
+-- | Parse a 'Host'. This is what we'll be using to read user
+--   input, since it supports both relative and absolute domain names
+--   (unlike the implicitly-absolute 'Domain').
+--
+--   ==== _Examples_
+--
+--   >>> import Text.Parsec ( parse, parseTest )
+--
+--   We can really parse the root now!
+--
+--   >>> parseTest user_domain "."
+--   HostAbsolute DomainRoot
+--
+--   But multiple dots aren't (only the first):
+--
+--   >>> pretty_print $ parse user_domain "" ".."
+--   .
+--
+--   We can also optionally have a trailing dot at the end of a
+--   non-empty name:
+--
+--   >>>  pretty_print $ parse user_domain "" "www.example.com"
+--   www.example.com
+--
+--   >>>  pretty_print $ parse user_domain "" "www.example.com."
+--   www.example.com.
+--
+--   A \"relative root\" can also be parsed, letting the user's
+--   resolver deal with it:
+--
+--   >>> parseTest user_domain ""
+--   HostRelative DomainRoot
+--
+host :: Parser Host
+host = try absolute <|> relative
+  where
+    absolute :: Parser Host
+    absolute = do
+      d <- domain
+      _ <- char '.'
+      return $ HostAbsolute d
+
+    relative :: Parser Host
+    relative = fmap HostRelative domain
+
+
+
+-- | 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 'Host' into a relative one.
+--
+--   ==== _Examples_
+--
+--   >>> import Text.Parsec ( parse )
+--
+--   >>> let (Right r) = parse host "" "1.2.3.4"
+--   >>> reverse_labels r
+--   "4.3.2.1"
+--
+--   >>> let (Right r) = parse host "" "www.example.com"
+--   >>> reverse_labels r
+--   "com.example.www"
+--
+--   Make sure absolute names are made relative:
+--
+--   >>> let (Right r) = parse host "" "www.example.com."
+--   >>> reverse_labels r
+--   "com.example.www"
+--
+reverse_labels :: Host -> DNS.Domain
+reverse_labels 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
+        (HostRelative _) -> pretty_show h
+        (HostAbsolute d) -> pretty_show d
+
+    dot = pack "."
+    labels = split '.' (pack relative_host_string)
+    reversed = intercalate dot (reverse labels)

diff --git a/src/Network/DNS/RBL/IPv4Pattern.hs b/harbl/src/Network/DNS/RBL/IPv4Pattern.hs
similarity index 100%
rename from src/Network/DNS/RBL/IPv4Pattern.hs
rename to harbl/src/Network/DNS/RBL/IPv4Pattern.hs

diff --git a/src/Network/DNS/RBL/Pretty.hs b/harbl/src/Network/DNS/RBL/Pretty.hs
similarity index 100%
rename from src/Network/DNS/RBL/Pretty.hs
rename to harbl/src/Network/DNS/RBL/Pretty.hs

diff --git a/src/Network/DNS/RBL/Site.hs b/harbl/src/Network/DNS/RBL/Site.hs
similarity index 97%
rename from src/Network/DNS/RBL/Site.hs
rename to harbl/src/Network/DNS/RBL/Site.hs
index 2bc63fa6e93a7113c059ff72081a7e03ebbe2179..ef0df315d678a58782f343df2f9d9abe8a58bcef 100644 (file)
--- a/src/Network/DNS/RBL/Site.hs
+++ b/harbl/src/Network/DNS/RBL/Site.hs
@@ -4,13 +4,12 @@
 --
 --     postscreen_dnsbl_sites = bl.mailspike.net=127.0.0.[2;10;11]*2, ...
 --
---   Here, the blacklist (a 'UserDomain') is \"bl.mailspike.net\", the
+--   Here, the blacklist (a 'Host') is \"bl.mailspike.net\", the
 --   return code pattern is \"127.0.0.[2;10;11]\", and the weight is
 --   \"2".
 --
 module Network.DNS.RBL.Site (
   Site(..),
-  Weight(..),
   site_tests,
   sites )
 where
@@ -34,7 +33,7 @@ import Text.Parsec (
 import Text.Parsec.String ( Parser )
 import Text.Read ( readMaybe )
 
-import Network.DNS.RBL.Domain ( UserDomain, user_domain )
+import Network.DNS.RBL.Host ( Host, host )
 import Network.DNS.RBL.IPv4Pattern ( IPv4Pattern, v4pattern )
 import Network.DNS.RBL.Pretty ( Pretty(..) )
 
@@ -99,7 +98,7 @@ weight = try parse_weight <|> return (Weight 1)
 --   (DNS) name, a pattern of addresses to use for a \"hit\", and a
 --   weight multiplier.
 --
-data Site = Site UserDomain (Maybe IPv4Pattern) Weight
+data Site = Site Host (Maybe IPv4Pattern) Weight
 
 
 -- | Pretty print DNSBL sites. This is straightforward except for the
@@ -148,7 +147,7 @@ instance Pretty Site where
 --
 site :: Parser Site
 site = do
-  d <- user_domain
+  d <- host
   return_codes <- optionMaybe $ char '=' >> v4pattern
   w <- weight
   return $ Site d return_codes w

diff --git a/makefile b/makefile
index f8efd9956aa87c830dd43d2681aec19ac653cf14..23882488be0548abb144ec193e2e189032c3c31d 100644 (file)
--- a/makefile
+++ b/makefile
@@ -1,6 +1,6 @@
 PN = harbl
 BIN = dist/build/$(PN)/$(PN)
-SRCS := $(shell find src/ -type f -name '*.hs')
+SRCS := $(shell find harbl{,-cli}/src/ -type f -name '*.hs')
 
 .PHONY : dist doc hlint
 

diff --git a/src/Main.hs b/src/Main.hs
deleted file mode 100644 (file)
index 52be522..0000000
--- a/src/Main.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-module Main
-where
-
-main :: IO ()
-main = putStrLn "Hello, world!"

diff --git a/src/Network/DNS/RBL/Host.hs b/src/Network/DNS/RBL/Host.hs
deleted file mode 100644 (file)
index ea7d4c8..0000000
--- a/src/Network/DNS/RBL/Host.hs
+++ /dev/null
@@ -1,73 +0,0 @@
-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)