Restructure everything to support a separate executable.
Get a basis stub executable working.
--- /dev/null
+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
--- /dev/null
+-- | 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)
--- /dev/null
+-- | 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
--- /dev/null
+-- | 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
--- /dev/null
+-- | 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
--- /dev/null
+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
--- /dev/null
+{-# 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)
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
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
main-is: TestSuite.hs
build-depends:
base >= 4.6 && < 5,
+ bytestring >= 0.9,
dns >= 2,
iproute >= 1.4,
parsec >= 3,
-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 )
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)
-- | 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
-> 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
-
-
-- (octets).
--
module Network.DNS.RBL.Domain (
- UserDomain(..),
- user_domain )
+ Domain,
+ domain )
where
import Data.Char ( toLower )
--
-- 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 |
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
--- /dev/null
+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)
--
-- 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
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(..) )
-- (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
--
site :: Parser Site
site = do
- d <- user_domain
+ d <- host
return_codes <- optionMaybe $ char '=' >> v4pattern
w <- weight
return $ Site d return_codes w
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
+++ /dev/null
-module Main
-where
-
-main :: IO ()
-main = putStrLn "Hello, world!"
+++ /dev/null
-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)