From b55e5db2a68be5d69b970bbe4b5ad447881abd3d Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Thu, 9 Jul 2015 22:54:04 -0400 Subject: [PATCH] Replace 'UserDomain' with 'Host' in the library. Restructure everything to support a separate executable. Get a basis stub executable working. --- harbl-cli/src/CommandLine.hs | 62 +++++++++ harbl-cli/src/Configuration.hs | 48 +++++++ harbl-cli/src/ExitCodes.hs | 32 +++++ harbl-cli/src/Hosts.hs | 47 +++++++ harbl-cli/src/Lists.hs | 47 +++++++ harbl-cli/src/Main.hs | 82 +++++++++++ harbl-cli/src/OptionalConfiguration.hs | 97 +++++++++++++ harbl.cabal | 46 ++++++- {src => harbl/src}/Network/DNS/RBL.hs | 60 ++++---- {src => harbl/src}/Network/DNS/RBL/Domain.hs | 79 +---------- harbl/src/Network/DNS/RBL/Host.hs | 130 ++++++++++++++++++ .../src}/Network/DNS/RBL/IPv4Pattern.hs | 0 {src => harbl/src}/Network/DNS/RBL/Pretty.hs | 0 {src => harbl/src}/Network/DNS/RBL/Site.hs | 9 +- makefile | 2 +- src/Main.hs | 5 - src/Network/DNS/RBL/Host.hs | 73 ---------- 17 files changed, 621 insertions(+), 198 deletions(-) create mode 100644 harbl-cli/src/CommandLine.hs create mode 100644 harbl-cli/src/Configuration.hs create mode 100644 harbl-cli/src/ExitCodes.hs create mode 100644 harbl-cli/src/Hosts.hs create mode 100644 harbl-cli/src/Lists.hs create mode 100644 harbl-cli/src/Main.hs create mode 100644 harbl-cli/src/OptionalConfiguration.hs rename {src => harbl/src}/Network/DNS/RBL.hs (55%) rename {src => harbl/src}/Network/DNS/RBL/Domain.hs (90%) create mode 100644 harbl/src/Network/DNS/RBL/Host.hs rename {src => harbl/src}/Network/DNS/RBL/IPv4Pattern.hs (100%) rename {src => harbl/src}/Network/DNS/RBL/Pretty.hs (100%) rename {src => harbl/src}/Network/DNS/RBL/Site.hs (97%) delete mode 100644 src/Main.hs delete mode 100644 src/Network/DNS/RBL/Host.hs diff --git a/harbl-cli/src/CommandLine.hs b/harbl-cli/src/CommandLine.hs new file mode 100644 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 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 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 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 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 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. +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 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 6ae0bba..8f4401f 100644 --- 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 3c32e5d..c3268fd 100644 --- 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 73a6988..75170a7 100644 --- 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 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 2bc63fa..ef0df31 100644 --- 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 f8efd99..2388248 100644 --- 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 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 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) -- 2.44.2