From: Michael Orlitzky <michael@orlitzky.com>
Date: Sat, 18 Jul 2015 03:40:43 +0000 (-0400)
Subject: Add a "threshold" to the configuration.
X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fharbl.git;a=commitdiff_plain;h=98b9d8768fe78d9948151e499ec52f7f616bd6e9

Add a "threshold" to the configuration.
---

diff --git a/harbl-cli/src/CommandLine.hs b/harbl-cli/src/CommandLine.hs
index a3481fe..9de575f 100644
--- a/harbl-cli/src/CommandLine.hs
+++ b/harbl-cli/src/CommandLine.hs
@@ -35,12 +35,18 @@ my_summary :: String
 my_summary = program_name ++ "-" ++ (showVersion version)
 
 
--- | A description of the "daemonize" option.
+-- | A description of the \"lists\" option.
 lists_help :: String
 lists_help =
   "A list of RBLs to check. See the manual for advanced syntax."
 
 
+-- | A description of the \"threshold\" option.
+threshold_help :: String
+threshold_help =
+  "The \"score\" a host must have to be considered blacklisted."
+
+
 -- | A data structure representing the possible command-line
 --   options. The CmdArgs library is doing heavy magic beneath the
 --   hood here.
@@ -48,8 +54,9 @@ lists_help =
 arg_spec :: OptionalConfiguration
 arg_spec =
   OptionalConfiguration {
-    hosts = def &= typ "HOSTS" &= args,
-    lists = def &= typ "RBLs"  &= help lists_help }
+    hosts     = def &= typ "HOSTS"   &= args,
+    lists     = def &= typ "RBLs"    &= help lists_help,
+    threshold = def &= typ "INTEGER" &= help threshold_help }
   &= program program_name
   &= summary my_summary
   &= details [description]
diff --git a/harbl-cli/src/Configuration.hs b/harbl-cli/src/Configuration.hs
index a6798e9..c3c55f0 100644
--- a/harbl-cli/src/Configuration.hs
+++ b/harbl-cli/src/Configuration.hs
@@ -7,14 +7,17 @@ module Configuration (
   merge_optional )
 where
 
-import Data.Monoid ( Monoid(..) )
+-- System imports.
 import System.Console.CmdArgs.Default ( Default(..) )
 
--- From the harbl library.
+-- Harbl library imports.
 import Network.DNS.RBL.Weight ( Weight )
 
+-- Local imports.
 import qualified OptionalConfiguration as OC (
-  OptionalConfiguration(..) )
+  OptionalConfiguration(..),
+  merge_maybe,
+  merge_monoid )
 import Hosts ( Hosts(..) )
 import Lists ( Lists(..) )
 
@@ -25,8 +28,8 @@ import Lists ( Lists(..) )
 data Configuration =
   Configuration {
     hosts  :: Hosts,
-    lists  :: Lists }
---    threshold :: Weight }
+    lists  :: Lists,
+    threshold :: Weight }
     deriving (Show)
 
 
@@ -35,8 +38,8 @@ data Configuration =
 --
 instance Default Configuration where
   def = Configuration { hosts = def,
-                        lists = def }
---                        threshold = def }
+                        lists = def,
+                        threshold = def }
 
 
 -- | Merge a 'Configuration' with an 'OptionalConfiguration'. This is
@@ -46,8 +49,8 @@ instance Default Configuration where
 merge_optional :: Configuration
                -> OC.OptionalConfiguration
                -> Configuration
-merge_optional cfg opt_cfg =
-  Configuration all_hosts all_lists
+merge_optional cfg opt_cfg = Configuration hs ls t
   where
-    all_hosts = (hosts cfg) `mappend` (OC.hosts opt_cfg)
-    all_lists = (lists cfg) `mappend` (OC.lists opt_cfg)
+    hs = OC.merge_monoid (hosts cfg) (OC.hosts opt_cfg)
+    ls = OC.merge_monoid (lists cfg) (OC.lists opt_cfg)
+    t  = OC.merge_maybe (threshold cfg) (OC.threshold opt_cfg)
diff --git a/harbl-cli/src/Hosts.hs b/harbl-cli/src/Hosts.hs
index 83bf7c3..cf70dc7 100644
--- a/harbl-cli/src/Hosts.hs
+++ b/harbl-cli/src/Hosts.hs
@@ -22,7 +22,7 @@ import Configurator ( convert_newtype_list )
 --
 newtype Hosts =
   Hosts { get_hosts :: [String] }
-    deriving (Data, Monoid, Show, Typeable)
+    deriving (Data, Eq, Monoid, Show, Typeable)
 
 
 -- | The default list of hosts. It's empty.
diff --git a/harbl-cli/src/Lists.hs b/harbl-cli/src/Lists.hs
index d94e85d..4870f89 100644
--- a/harbl-cli/src/Lists.hs
+++ b/harbl-cli/src/Lists.hs
@@ -22,7 +22,7 @@ import Configurator ( convert_newtype_list )
 --
 newtype Lists =
   Lists { get_lists :: [String] }
-    deriving (Data, Monoid, Show, Typeable)
+    deriving (Data, Eq, Monoid, Show, Typeable)
 
 
 -- | The default list of white/blacklists. It's empty.
diff --git a/harbl-cli/src/OptionalConfiguration.hs b/harbl-cli/src/OptionalConfiguration.hs
index 35ca7d4..37d05a9 100644
--- a/harbl-cli/src/OptionalConfiguration.hs
+++ b/harbl-cli/src/OptionalConfiguration.hs
@@ -11,6 +11,8 @@
 --
 module OptionalConfiguration (
   OptionalConfiguration(..),
+  merge_maybe,
+  merge_monoid,
   from_rc )
 where
 
@@ -30,6 +32,9 @@ import System.FilePath ( (</>) )
 import System.IO.Error ( catchIOError )
 import System.IO ( hPutStrLn, stderr )
 
+-- Harbl library imports.
+import Network.DNS.RBL.Weight ( Weight )
+
 -- Local imports.
 import Hosts ( Hosts(..) )
 import Lists ( Lists(..) )
@@ -43,10 +48,88 @@ import Lists ( Lists(..) )
 data OptionalConfiguration =
   OptionalConfiguration {
     hosts :: Hosts,
-    lists :: Lists }
+    lists :: Lists,
+    threshold :: Maybe Weight }
     deriving (Show, Data, Typeable)
 
 
+-- | Choose a nonempty monoid from our two arguments, preferring the
+--   second. So if the second monoid is non-'mempty', we'll return
+--   that. Otherwise the first.
+--
+--   ==== _Examples_
+--
+--   The second list is preferred if both are nonempty:
+--
+--   >>> merge_monoid [1,2] [3,4]
+--   [3,4]
+--
+--   However, if the second list is empty, the first is returned:
+--
+--   >>> merge_monoid [1,2] []
+--   [1,2]
+--
+--   And if both are empty, we return the first (i.e. empty) list:
+--
+--   >>> merge_monoid [] []
+--   []
+--
+merge_monoid :: (Eq a, Monoid a) => a -> a -> a
+merge_monoid l1 l2 = if l2 == mempty then l1 else l2
+
+
+-- | Like 'merge_monoid', except for optional things. We take two
+--   (potentially 'Nothing') values, and then try to choose a
+--   non-'Nothing' one, preferring the second argument.
+--
+--   ==== _Examples_
+--
+--   The second is preferred if it is non-'Nothing':
+--
+--   >>> merge_maybes (Just 3) (Just 4)
+--   Just 4
+--
+--   >>> merge_maybes Nothing (Just 4)
+--   Just 4
+--
+--   However, if the second argument is 'Nothing', the first is
+--   returned:
+--
+--   >>> merge_maybes (Just 1) Nothing
+--   Just 1
+--
+--   If both are 'Nothing', we return 'Nothing':
+--
+--   >>> merge_maybes Nothing Nothing
+--   Nothing
+--
+merge_maybes :: (Maybe a) -> (Maybe a) -> (Maybe a)
+merge_maybes _ y@(Just _) = y
+merge_maybes x@(Just _) Nothing = x
+merge_maybes Nothing Nothing = Nothing
+
+
+-- | Return the (thing contained in the) second argument if it is
+--   non-'Nothing'. Otherwise return the first argument.
+--
+--   ==== _Examples_
+--
+--   The second is preferred if it is non-'Nothing':
+--
+--   >>> merge_maybe 3 (Just 4)
+--   4
+--
+--   However, if the second argument is 'Nothing', the first is
+--   returned:
+--
+--   >>> merge_maybe 1 Nothing
+--   1
+--
+merge_maybe :: a -> Maybe a -> a
+merge_maybe x Nothing = x
+merge_maybe _ (Just y) = y
+
+
 -- | 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
@@ -57,18 +140,14 @@ data OptionalConfiguration =
 --
 instance Monoid OptionalConfiguration where
   -- | An empty OptionalConfiguration.
-  mempty = OptionalConfiguration (Hosts []) (Lists [])
-
+  mempty = OptionalConfiguration mempty mempty Nothing
 
   -- | 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
+  cfg1 `mappend` cfg2 = OptionalConfiguration hs ls t
     where
-      all_hosts = Hosts $ (get_hosts $ hosts cfg1) ++ (get_hosts $ hosts cfg2)
-      all_lists = Lists $ (get_lists $ lists cfg1) ++ (get_lists $ lists cfg2)
-
+      hs = merge_monoid (hosts cfg1) (hosts cfg2)
+      ls = merge_monoid (lists cfg1) (lists cfg2)
+      t  = merge_maybes (threshold cfg1) (threshold cfg2)
 
 
 -- | Obtain an OptionalConfiguration from harblrc in either the global
@@ -93,5 +172,9 @@ from_rc = do
   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)
+  cfg_hosts <- DC.lookup cfg "hosts"
+  cfg_threshold <- DC.lookup cfg "threshold"
+  return $ OptionalConfiguration
+             (fromMaybe def cfg_hosts)
+             (fromMaybe def cfg_lists)
+             cfg_threshold
diff --git a/harbl.cabal b/harbl.cabal
index e59c437..24a67c2 100644
--- a/harbl.cabal
+++ b/harbl.cabal
@@ -18,6 +18,7 @@ library
     base                        >= 4.6 && < 5,
     bytestring                  >= 0.9,
     cmdargs                     >= 0.10.6,
+    configurator                >= 0.2,
     dns                         >= 2,
     iproute                     >= 1.4,
     parsec                      >= 3,
diff --git a/harbl/src/Network/DNS/RBL/Weight.hs b/harbl/src/Network/DNS/RBL/Weight.hs
index 8447ab3..db8c7a7 100644
--- a/harbl/src/Network/DNS/RBL/Weight.hs
+++ b/harbl/src/Network/DNS/RBL/Weight.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 -- | The 'Weight' type, its instances, and a Parsec parser to parse
@@ -15,6 +16,11 @@ module Network.DNS.RBL.Weight (
   weight )
 where
 
+import Data.Configurator () -- Needed for predefined instances.
+import Data.Configurator.Types ( Configured(..), Value( Number ), convert )
+import Data.Data ( Data )
+import Data.Ratio ( numerator )
+import Data.Typeable ( Typeable )
 import System.Console.CmdArgs.Default ( Default(..) )
 import Text.Parsec (
   (<|>),
@@ -48,7 +54,7 @@ import Network.DNS.RBL.Pretty ( Pretty(..) )
 --   >>> sum [w1, w2, w3]
 --   Weight 4
 --
-newtype Weight = Weight Int deriving (Eq, Num, Ord, Show)
+newtype Weight = Weight Int deriving (Data, Eq, Num, Ord, Show, Typeable)
 
 
 -- | Pretty-print a 'Weight'. This just shows/prints the underlying 'Int'.
@@ -74,6 +80,27 @@ instance Pretty Weight where
 instance Default Weight where def = 1
 
 
+-- | Allow the configurator library to parse a 'Weight' from a config
+--   file.
+--
+--   ==== _Examples_
+--
+--   >>> import Data.Configurator () -- Get predefined 'Configured' instances.
+--   >>> import Data.Text ( pack )
+--   >>> import Data.Configurator.Types ( Value( Number, String ) )
+--   >>> let n1 = Number 2
+--   >>> convert n1 :: Maybe Weight
+--   Just (Weight 2)
+--   >>> let s = String (pack "foo1")
+--   >>> convert s :: Maybe Weight
+--   Nothing
+--
+instance Configured Weight where
+  -- Don't give us a fractional weight, we'll ignore the denominator.
+  convert (Number x) = Just (Weight (fromInteger $ numerator x))
+  convert _          = Nothing
+
+
 -- | Parse the weight multiplier off the end of an input 'Site'. This
 --   expects there to be a \"multiplier\" character (an asterisk)
 --   before the integral weight.