X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fharbl.git;a=blobdiff_plain;f=harbl-cli%2Fsrc%2FMain.hs;fp=harbl-cli%2Fsrc%2FMain.hs;h=d2ac8d294ed7c0751f6d30df678e31d6759dff8f;hp=0000000000000000000000000000000000000000;hb=b55e5db2a68be5d69b970bbe4b5ad447881abd3d;hpb=c4d41b93ec02ff4dc762163441ebefb0324e6f07

diff --git a/harbl-cli/src/Main.hs b/harbl-cli/src/Main.hs
new file mode 100644
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