From f75845314598408bce3a1b972f2ba274d93d0e8d Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Fri, 28 Nov 2014 00:00:25 -0500 Subject: [PATCH 1/1] Get things in shape finally: * Move the Forward code into its own module. * Separate out the excluded MX filtering magic. * Write tons of tests for the MX filtering. * Normalize every name used in a comparison. * Use Data.Map and Data.Set for MX filtering. * Update some documentation. * Update the ghci file with new modules. * Add the Forward module to the cabal file. * Make sure no spurious newlines are output. * Update the TODO. --- .ghci | 24 ++- doc/TODO | 7 +- doc/list-remote-forwardsrc.example | 6 +- doc/man1/list-remote-forwards.1 | 10 +- list-remote-forwards.cabal | 11 +- src/DNS.hs | 76 +++++++- src/Forward.hs | 251 ++++++++++++++++++++++++++ src/Main.hs | 2 +- src/Report.hs | 273 ++++++++++++++++------------- 9 files changed, 519 insertions(+), 141 deletions(-) create mode 100644 src/Forward.hs diff --git a/.ghci b/.ghci index 9c70fd2..23b1594 100644 --- a/.ghci +++ b/.ghci @@ -1,8 +1,28 @@ :set -isrc -idist/build/autogen -:load src/Main.hs -:load src/Report.hs + +:{ +:load src/CommandLine.hs + src/Configuration.hs + src/DNS.hs + src/Forward.hs + src/Main.hs + src/MxList.hs + src/OptionalConfiguration.hs + src/Report.hs + src/String.hs +:} import Database.HDBC import Database.HDBC.Sqlite3 +import CommandLine +import Configuration +import DNS +import Forward +import Main +import MxList +import OptionalConfiguration +import Report +import String + :set prompt "list-remote-forwards> " diff --git a/doc/TODO b/doc/TODO index 663f403..0e57166 100644 --- a/doc/TODO +++ b/doc/TODO @@ -1,2 +1,5 @@ -1. The --exclude-mx option doesn't work! - +1. Use the type system to prevent all the bugs that arise from + (de)normalization of domain names. We should use newtype wrappers + around string domain names that we can only create by using a + normalize_foo constructor. That way we can make sure that we never + do a comparison on a denormalized name. diff --git a/doc/list-remote-forwardsrc.example b/doc/list-remote-forwardsrc.example index 3e43560..86b52ce 100644 --- a/doc/list-remote-forwardsrc.example +++ b/doc/list-remote-forwardsrc.example @@ -21,12 +21,12 @@ # The name of a mail exchanger, the forwards of whose domains we should # ignore. For example, if one mail exchanger, mx1.example.com, has # strict spam filtering, it may be acceptable to have remote forwarding -# for domains that have mx1.example.com as their mail exchanger (MX +# for domains that have mx1.example.com as their sole mail exchanger (MX # record). In that case, you might want to exclude those domains from # the report, by naming mx1.example.com here. # -# Given as a list, it can be used to exclude more than one mail -# exchanger. +# A forward will be excluded from the report only if *all* of its MX +# records are contained in the given exclude list. # # Default: [] (empty) # diff --git a/doc/man1/list-remote-forwards.1 b/doc/man1/list-remote-forwards.1 index 13ebb4a..77eec6e 100644 --- a/doc/man1/list-remote-forwards.1 +++ b/doc/man1/list-remote-forwards.1 @@ -53,11 +53,14 @@ Default: \(dqSELECT domain FROM domain WHERE domain <> 'ALL' ORDER BY domain;\(d The name of a mail exchanger, the forwards of whose domains we should ignore. For example, if one mail exchanger, mx1.example.com, has strict spam filtering, it may be acceptable to have remote forwarding -for domains that have mx1.example.com as their mail exchanger (MX +for domains that have mx1.example.com as their sole mail exchanger (MX record). In that case, you might want to exclude those domains from the report by naming mx1.example.com here. -Can be repeated to exclude more than one mail exchanger. +A forward will be excluded from the report only if \fIall\fR of its MX +records are contained in the given exclude list. + +This option can be repeated to add mail exchangers to the exclude list. Default: [] (empty) @@ -93,11 +96,12 @@ Default: The current user .SH EXAMPLES .nf -.I $ list-remote-forwards --database=postfixadmin.sqlite3 +.I $ list-remote-forwards --database=test/fixtures/postfixadmin.sqlite3 user1@example.com -> user1@example.net user2@example.com -> user1@example.org user2@example.com -> user2@example.org user2@example.com -> user3@example.org +user7@example.com -> user8@example.net .fi .SH BUGS .P diff --git a/list-remote-forwards.cabal b/list-remote-forwards.cabal index 4718b35..ba8ffa4 100644 --- a/list-remote-forwards.cabal +++ b/list-remote-forwards.cabal @@ -79,11 +79,14 @@ description: The name of a mail exchanger, the forwards of whose domains we should ignore. For example, if one mail exchanger, mx1.example.com, has strict spam filtering, it may be acceptable to have remote forwarding - for domains that have mx1.example.com as their mail exchanger (MX + for domains that have mx1.example.com as their sole mail exchanger (MX record). In that case, you might want to exclude those domains from the report by naming mx1.example.com here. . - Can be repeated to exclude more than one mail exchanger. + A forward will be excluded from the report only if /all/ of its MX + records are contained in the given exclude list. + . + This option can be repeated to add mail exchangers to the exclude list. . Default: [] (empty) . @@ -133,7 +136,7 @@ description: /Examples/: . @ - $ list-remote-forwards --database=postfixadmin.sqlite3 + $ list-remote-forwards --database=test/fixtures/postfixadmin.sqlite3 user1@example.com -> user1@example.net user2@example.com -> user1@example.org user2@example.com -> user2@example.org @@ -168,9 +171,11 @@ executable list-remote-forwards Configuration CommandLine DNS + Forward OptionalConfiguration MxList Report + String ghc-options: -Wall diff --git a/src/DNS.hs b/src/DNS.hs index 6010fc9..8d94de5 100644 --- a/src/DNS.hs +++ b/src/DNS.hs @@ -1,13 +1,43 @@ -module DNS ( lookup_mxs ) +module DNS ( + MxSetMap, + mx_set_map, + normalize_string_domain ) where +import qualified Data.ByteString.Char8 as BS ( pack, unpack ) +import Data.List ( nub ) +import Data.Map ( Map ) +import qualified Data.Map as Map ( fromList ) +import Data.Set ( Set ) +import qualified Data.Set as Set ( fromList ) import Network.DNS ( Domain, defaultResolvConf, lookupMX, makeResolvSeed, + normalize, withResolver ) +-- | A map from domain names (represented as 'String's) to sets of +-- mail exchanger names (also represented as 'String's). +-- +type MxSetMap = Map String MxSet + +-- | A set of mail exchanger names, represented as 'String's. +type MxSet = Set String + + +-- | Normalize a domain name string by converting to a 'Domain', +-- calling 'normalize', and then converting back. +-- +-- ==== __Examples__ +-- +-- >>> normalize_string_domain "ExAMplE.com" +-- "example.com." +-- +normalize_string_domain :: String -> String +normalize_string_domain = BS.unpack . normalize . BS.pack + -- | Retrieve all MX records for the given domain. This is somewhat -- inefficient, since we create the resolver every time. @@ -20,3 +50,47 @@ lookup_mxs domain = do return $ case mxs of Left _ -> [] Right pairs -> map fst pairs + + +-- | Takes a list of domain names represented as 'String's and +-- constructs a map from domain names to sets of mail exchangers +-- (for those domain names) also represented as 'String's. +-- +-- During construction, we have to switch to the DNS internal +-- representation of a 'Domain' which uses ByteStrings, but before +-- we return the map to the client, we want everything to be in +-- terms of standard 'String's for comparison purposes. +-- +-- The list of domains is normalized and de-duped before lookups are +-- performed to avoid doing lookups twice for identical domains. +-- +mx_set_map :: [String] -> IO MxSetMap +mx_set_map domains = do + -- Construct a list of pairs. + pairs <- mapM make_pair unique_domains + + -- And make a map from the pairs. + return $ Map.fromList pairs + + where + -- Convert, normalize, and de-dupe the @domains@. + unique_domains :: [Domain] + unique_domains = nub $ map (normalize . BS.pack) domains + + -- | Convert a string domain name into a pair containing the + -- domain name in the first component and a set of its mail + -- exchangers (as strings) in the second component. + -- + make_pair :: Domain -> IO (String, Set String) + make_pair domain = do + -- Lookup the @domain@'s MX records. + mx_list <- lookup_mxs domain + + -- Now convert the MX records *back* to strings. + let string_mx_list = map BS.unpack mx_list + + -- Convert the list into a set + let string_mx_set = Set.fromList string_mx_list + + -- Finally, construct the pair and return it. + return (BS.unpack domain, string_mx_set) diff --git a/src/Forward.hs b/src/Forward.hs new file mode 100644 index 0000000..7de53b8 --- /dev/null +++ b/src/Forward.hs @@ -0,0 +1,251 @@ +-- | The 'Forward' data type, and functions that act thereon. +-- +module Forward ( + Forward(..), + address_domain, + dropby_goto_domains, + fwd, + pretty_print, + strings_to_forwards ) +where + +import Data.String.Utils ( split, strip ) + +import DNS ( normalize_string_domain ) + +-- | Type synonym to make the signatures below a little more clear. +-- WARNING: Also defined in the "Report" module. +type Domain = String + + +-- | A type-safe wrapper around an email address that's represented as +-- a 'String'. This differs from a 'Goto' in that it should only +-- appear on the left-hand-side of a alias -> goto relationship. +-- +newtype Address = Address String deriving ( Show ) + + +-- | A type-safe wrapper around an email address that's represented as +-- a 'String'. This differs from 'Address' in that 'Goto' addresses +-- are the destinations of mail that is forwarded, rather than the +-- source. +newtype Goto = Goto String deriving ( Show ) + + +-- | A data type representing a "forward." That is, an email address +-- whose mail is sent to some other address. +-- +-- The 'Address' field represents the alias address, the address to +-- which mail is sent. The 'Goto' field is the address to which the +-- mail is forwarded. +-- +data Forward = + Forward Address Goto + deriving (Show) + + +-- | Shortcut constructor for creating 'Forward' objects. +-- +-- ==== __Examples__ +-- +-- >>> pretty_print $ fwd "user1@example.com" "user2@example.net" +-- "user1@example.com -> user2@example.net" +-- +fwd :: String -> String -> Forward +fwd addr goto = Forward (Address addr) (Goto goto) + + +-- | Pretty-print a 'Forward'. +-- +-- ==== __Examples__ +-- +-- >>> pretty_print (fwd "a@example.com" "b@example.net") +-- "a@example.com -> b@example.net" +-- +pretty_print :: Forward -> String +pretty_print ( Forward (Address addr) (Goto goto) ) = + addr ++ " -> " ++ goto + + + +-- | Convert a list of 'String's into a list of 'Forward's. The list +-- of 'String's is assumed to have exactly two elements; the first +-- being an address, and the second being a comma-separated list of +-- gotos. +-- +-- We return a list containing one 'Forward' for each (address,goto) +-- pair. +-- +-- ==== __Examples__ +-- +-- A single address, pointed to itself (common with PostfixAdmin): +-- +-- >>> let addr = "a@b.test" +-- >>> let gotos = "a@b.test" +-- >>> strings_to_forwards [addr, gotos] +-- [Forward (Address "a@b.test") (Goto "a@b.test")] +-- +-- One address forwarded to two other addresses: +-- +-- >>> let addr = "a@b.test" +-- >>> let gotos = "a1@b.test,a2@b.test" +-- >>> map pretty_print (strings_to_forwards [addr, gotos]) +-- ["a@b.test -> a1@b.test","a@b.test -> a2@b.test"] +-- +-- An address that receives mail itself, but also forwards a copy to +-- another address (also common in PostfixAdmin). We've also mangled +-- the whitespace a little bit here: +-- +-- >>> let addr = "a@b.test" +-- >>> let gotos = "a@b.test ,a2@b.test " +-- >>> map pretty_print (strings_to_forwards [addr, gotos]) +-- ["a@b.test -> a@b.test","a@b.test -> a2@b.test"] +-- +-- And finally, a one-element list, which should return no forwards: +-- +-- >>> let addr = "a@b.test" +-- >>> strings_to_forwards [addr] +-- [] +-- +strings_to_forwards :: [String] -> [Forward] +strings_to_forwards (addr:gotos:_) = + [Forward (Address addr) (Goto (strip g)) | g <- split "," gotos] +strings_to_forwards _ = [] + + +-- | Find the domain of the 'Goto' associated with a 'Forward'. This +-- returns the __domain of the goto address__, not the domain of the +-- 'Address' itself. +-- +-- ==== __Examples__ +-- +-- A normal forward: +-- +-- >>> let f = fwd "user1@example.com" "user2@example.net" +-- >>> goto_domain f +-- Just "example.net" +-- +-- A forward to a subdomain: +-- +-- >>> let f = fwd "user1@example.com" "user2@sub.example.net" +-- >>> goto_domain f +-- Just "sub.example.net" +-- +-- A goto without an '@' character: +-- +-- >>> let f = fwd "user1@example.com" "example.net" +-- >>> goto_domain f +-- Nothing +-- +-- A goto with three '@' characters: +-- +-- >>> let f = fwd "user1@example.com" "@example@.net@" +-- >>> goto_domain f +-- Nothing +-- +goto_domain :: Forward -> Maybe Domain +goto_domain (Forward _ (Goto goto)) = domain_part goto + + +-- | Find the domain of the 'Address' associated with a 'Forward'. This +-- returns the __domain of the address__, not the domain of the +-- 'Goto'. +-- +-- ==== __Examples__ +-- +-- A normal forward: +-- +-- >>> let f = fwd "user1@example.com" "user2@example.net" +-- >>> address_domain f +-- Just "example.com" +-- +-- A forward to/from subdomains: +-- +-- >>> let f = fwd "user1@sub.example.com" "user2@sub.example.net" +-- >>> address_domain f +-- Just "sub.example.com" +-- +-- An address/goto without an '@' character: +-- +-- >>> let f = fwd "example.com" "example.net" +-- >>> address_domain f +-- Nothing +-- +-- An address/goto with three '@' characters: +-- +-- >>> let f = fwd "@example@.com@" "@example@.net@" +-- >>> address_domain f +-- Nothing +-- +address_domain :: Forward -> Maybe Domain +address_domain (Forward (Address addr) _) = domain_part addr + + +-- | Return the domain part of an email address (represented by a +-- 'String'). +-- +-- The way we determine the domain is simple: we take whatever +-- appears after the first '@' character in the address. If there is +-- no '@' symbol, or if there's more than one, then we don't know +-- what the domain is, so we return 'Nothing' instead. +-- +-- ==== __Examples__ +-- +-- A normal address: +-- +-- >>> domain_part "user2@example.net" +-- Just "example.net" +-- +-- A subdomain: +-- +-- >>> domain_part "user2@sub.example.net" +-- Just "sub.example.net" +-- +-- An address without an '@' character: +-- +-- >>> domain_part "example.net" +-- Nothing +-- +-- An address with two '@' characters: +-- +-- >>> domain_part "@example@.net@" +-- Nothing +-- +domain_part :: String -> Maybe Domain +domain_part address = + case parts of + (_:domain:[]) -> Just domain + _ -> Nothing + where + parts = split "@" address + + +-- | Given a list of 'Domain's @domains@ and a list of 'Forward's +-- @forwards@, filter out all elements of @forwards@ that have a +-- goto domain in the list of @domains@. +-- +-- ==== __Examples__ +-- +-- >>> let ds = ["example.com", "example.net"] +-- >>> let f1 = fwd "a@example.com" "a@example.com" +-- >>> let f2 = fwd "a@example.com" "a1@example.net" +-- >>> let f3 = fwd "a@example.com" "a2@example.org" +-- >>> map pretty_print (dropby_goto_domains ds [f1,f2,f3]) +-- ["a@example.com -> a2@example.org"] +-- +dropby_goto_domains :: [Domain] -> [Forward] -> [Forward] +dropby_goto_domains domains = + filter (not . is_bad) + where + -- If we don't normalize these first, comparison (i.e. `elem`) + -- doesn't work so great. + normalized_domains = map normalize_string_domain domains + + -- | A 'Forward' is bad if its goto domain appears in the list, or + -- if we can't figure out its goto domain. + -- + is_bad :: Forward -> Bool + is_bad f = + case (goto_domain f) of + Nothing -> True -- Drop these, too. + Just d -> (normalize_string_domain d) `elem` normalized_domains diff --git a/src/Main.hs b/src/Main.hs index 13371a8..ab4d055 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -74,7 +74,7 @@ main = do else connectPostgreSQL (connection_string cfg) >>= report cfg -- The DB connection is implicitly closed when it gets garbage collected. - putStrLn r + putStr r where show_sql_error :: SqlError -> IO () diff --git a/src/Report.hs b/src/Report.hs index a189664..5b38533 100644 --- a/src/Report.hs +++ b/src/Report.hs @@ -5,41 +5,35 @@ module Report ( report_tests ) where -import Control.Monad ( filterM ) -import qualified Data.ByteString.Char8 as BS ( pack ) +import Data.Map ( mapKeys ) +import qualified Data.Map as Map ( lookup ) import Data.Maybe ( catMaybes, listToMaybe ) -import Data.String.Utils ( join, split, strip ) +import Data.Set ( fromList, isSubsetOf ) +import qualified Data.Set as Set ( map ) +import Data.String.Utils ( join ) import Database.HDBC ( IConnection, execute, prepare, sFetchAllRows') import Database.HDBC.Sqlite3 ( connectSqlite3 ) -import Data.List ( (\\) ) -import Network.DNS.Utils ( normalize ) import System.Console.CmdArgs.Default ( Default(..) ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Configuration ( Configuration(..) ) -import DNS ( lookup_mxs ) +import DNS ( MxSetMap, mx_set_map, normalize_string_domain ) +import Forward ( + Forward(..), + address_domain, + dropby_goto_domains, + pretty_print, + strings_to_forwards ) import MxList ( MxList(..) ) --- Type synonyms to make the signatures below a little more clear. +-- | Type synonym to make the signatures below a little more clear. +-- WARNING: Also defined in the "Forward" module. type Domain = String -type Address = String -type Goto = String - --- | A data type representing a "forward." That is, an email address --- whose mail is sent to some other address. --- --- The 'Address' field represents the alias address, the address to --- which mail is sent. The 'Goto' field is the address to which the --- mail is forwarded. --- -data Forward = - Forward Address Goto - deriving (Show) -- | Given a connection @conn@ and a @query@, return a list of domains -- found by executing @query@ on @conn. The @query@ is assumed to @@ -69,48 +63,6 @@ get_domain_list conn query = do return domains --- | Convert a row obtained in 'get_forward_list' into a list of --- 'Forward's. The row is assumed to have two columns, the first --- with an address, and the second with a comma-separated list of --- gotos. --- --- We return a list containing one entry for each address, goto pair. --- --- ==== __Examples__ --- --- A single address, pointed to itself (common with PostfixAdmin): --- --- >>> let addr = "a@b.test" --- >>> let gotos = "a@b.test" --- >>> row_to_forwards [addr, gotos] --- [Forward "a@b.test" "a@b.test"] --- --- One address forwarded to two other addresses: --- --- >>> let addr = "a@b.test" --- >>> let gotos = "a1@b.test,a2@b.test" --- >>> row_to_forwards [addr, gotos] --- [Forward "a@b.test" "a1@b.test",Forward "a@b.test" "a2@b.test"] --- --- An address that receives mail itself, but also forwards a copy to --- another address (also common in PostfixAdmin). We've also mangled --- the whitespace a little bit here: --- --- >>> let addr = "a@b.test" --- >>> let gotos = "a@b.test ,a2@b.test " --- >>> row_to_forwards [addr, gotos] --- [Forward "a@b.test" "a@b.test",Forward "a@b.test" "a2@b.test"] --- --- And finally, a one-element list, which should return no forwards: --- --- >>> let addr = "a@b.test" --- >>> row_to_forwards [addr] --- [] --- -row_to_forwards :: [String] -> [Forward] -row_to_forwards (addr:gotos:_) = - [Forward addr (strip g) | g <- split "," gotos] -row_to_forwards _ = [] -- | Given a connection @conn@ and a @query@, return a list of @@ -135,81 +87,133 @@ get_forward_list conn query = do rows <- sFetchAllRows' stmt -- forwards :: [Forward] - let forwards = concatMap (row_to_forwards . catMaybes) rows + let forwards = concatMap (strings_to_forwards . catMaybes) rows return forwards --- | Given a list of local 'Domain's and a list of 'Forward's, filter --- out all of the local forwards and return only the remaining --- (remote) forwards. +-- | A filter function to remove specific 'Forward's from a list (of +-- forwards). Its intended usage is to ignore a 'Forward' if its +-- 'Address' has MX records that are all contained in the given +-- list. This could be useful if, for example, one MX has strict +-- spam filtering and remote forwards are not a problem for domains +-- with that MX. -- --- ==== __Examples__ +-- If the MX records for a domain are contained in the 'MxList', +-- then we exclude that domain from the report. -- --- >>> let ds = ["example.com", "example.net"] --- >>> let f1 = Forward "a@example.com" "a@example.com" --- >>> let f2 = Forward "a@example.com" "a1@example.net" --- >>> let f3 = Forward "a@example.com" "a2@example.org" --- >>> find_remote_forwards ds [f1,f2,f3] --- [Forward "a@example.com" "a2@example.org"] +-- For performance reasons, we want to have precomputed the MX +-- records for all of the address domains in our list of +-- forwards. We do this so we don't look up the MX records twice for +-- two addresses within the same domain. We could just as well do +-- this within this function, but by taking the @domain_mxs@ as a +-- parameter, we allow ourselves to be a pure function. -- -find_remote_forwards :: [Domain] -> [Forward] -> [Forward] -find_remote_forwards domains forwards = - filter is_remote forwards - where - is_remote :: Forward -> Bool - is_remote (Forward _ goto) = - let parts = split "@" goto - in - case parts of - (_:dp:[]) -> not $ dp `elem` domains - _ -> True -- Assume it's remote if something is wrong - - --- | Format a 'Forward' for pretty printing. +-- If the domain of a forward address can't be determined, it won't +-- be dropped! This is intentional: the existence of a forward +-- address without a domain part probably indicates a configuration +-- error somewhere, and we should report it. +-- +-- The empty @MxList []@ special case is necessary! Otherwise if we +-- have an empty exclude list and a domain that has no MX record, it +-- will be excluded. -- -- ==== __Examples__ -- --- >>> let fwd = Forward "a@example.com" "b@example.net" --- >>> format_forward fwd --- "a@example.com -> b@example.net" +-- Our single forward should be dropped from the list, because its +-- MX record list, ["mx.example.com"], is contained in the list of +-- excluded MXs: -- -format_forward :: Forward -> String -format_forward (Forward addr goto) = - addr ++ " -> " ++ goto - - - --- | A filter function to remove specific 'Forward's from a list (of --- fowards). Its intended usage is to ignore a 'Forward' if its --- 'Address' has an MX record contained in the given list. This --- could be useful if, for example, one MX has strict spam filtering --- and remote forwards are not a problem for domains with that MX. +-- >>> import qualified Data.Map as Map ( fromList ) +-- >>> import qualified Data.Set as Set ( fromList ) +-- >>> import Forward ( fwd ) +-- >>> let fwds = [fwd "user1@example.com" "user2@example.net"] +-- >>> let mx_set = Set.fromList ["mx.example.com"] +-- >>> let example_mx_pairs = [("example.com.", mx_set)] +-- >>> let mx_map = Map.fromList example_mx_pairs +-- >>> let droplist = MxList ["mx.example.com", "mx2.example.com"] +-- >>> map pretty_print (dropby_mxlist droplist mx_map fwds) +-- [] -- --- If the MX records for a domain are exactly those contained in the --- 'MxList', then we exclude that domain from the report. Splitting on --- the '@' is a lazy way of obtaining the domain, but if it's good --- enough for determining that a forward is remote, then it's good --- enough for this. +-- Repeat the previous test with the goto domain, to make sure we're +-- dropping based on the address and not the goto: -- --- The empty @MxList []@ special case is necessary! Otherwise if we --- have an empty exclude list and a domain that has no MX record, it --- will be excluded. +-- >>> import qualified Data.Map as Map ( fromList ) +-- >>> import qualified Data.Set as Set ( fromList ) +-- >>> let fwds = [fwd "user1@example.com" "user2@example.net"] +-- >>> let mx_set = Set.fromList ["mx.example.net"] +-- >>> let example_mx_pairs = [("example.net.", mx_set)] +-- >>> let mx_map = Map.fromList example_mx_pairs +-- >>> let droplist = MxList ["mx.example.net", "mx2.example.net"] +-- >>> map pretty_print (dropby_mxlist droplist mx_map fwds) +-- ["user1@example.com -> user2@example.net"] -- -filter_by_mx :: MxList -> [Forward] -> IO [Forward] -filter_by_mx (MxList []) = return -filter_by_mx (MxList mxs) = - filterM all_mxs_excluded +-- Use weird caps, and optional trailing dot all over the place to +-- make sure everything is handled normalized: +-- +-- >>> import qualified Data.Set as Set ( fromList ) +-- >>> import Forward ( fwd ) +-- >>> let fwds = [fwd "user1@exAmPle.com." "user2@examPle.net"] +-- >>> let mx_set = Set.fromList ["mx.EXAMPLE.com"] +-- >>> let example_mx_pairs = [("Example.com", mx_set)] +-- >>> let mx_map = Map.fromList example_mx_pairs +-- >>> let droplist = MxList ["mx.EXAMple.com", "mx2.example.COM"] +-- >>> map pretty_print (dropby_mxlist droplist mx_map fwds) +-- [] +-- +-- This time it shouldn't be dropped, because ["mx.example.com"] is +-- not contained in ["nope.example.com"]: +-- +-- >>> import qualified Data.Map as Map ( fromList ) +-- >>> import qualified Data.Set as Set ( fromList ) +-- >>> let fwds = [fwd "user1@example.com" "user2@example.net"] +-- >>> let mx_set = Set.fromList ["mx.example.com"] +-- >>> let example_mx_pairs = [("example.com.", mx_set)] +-- >>> let mx_map = Map.fromList example_mx_pairs +-- >>> let droplist = MxList ["nope.example.com"] +-- >>> map pretty_print (dropby_mxlist droplist mx_map fwds) +-- ["user1@example.com -> user2@example.net"] +-- +-- Now we check that if a forward has two MXes, one of which appears +-- in the list of excluded MXes, it doesn't get dropped: +-- +-- >>> import qualified Data.Map as Map ( fromList ) +-- >>> import qualified Data.Set as Set ( fromList ) +-- >>> let fwds = [fwd "user1@example.com" "user2@example.net"] +-- >>> let mx_set = Set.fromList ["mx1.example.com", "mx2.example.com"] +-- >>> let example_mx_pairs = [("example.com.", mx_set)] +-- >>> let mx_map = Map.fromList example_mx_pairs +-- >>> let droplist = MxList ["mx1.example.com"] +-- >>> map pretty_print (dropby_mxlist droplist mx_map fwds) +-- ["user1@example.com -> user2@example.net"] +-- +dropby_mxlist :: MxList -> MxSetMap -> [Forward] -> [Forward] +dropby_mxlist (MxList []) _ = id +dropby_mxlist (MxList mxs) domain_mx_map = + filter (not . is_bad) where - all_mxs_excluded :: Forward -> IO Bool - all_mxs_excluded (Forward addr _) = - case (split "@" addr) of - (_:domain_part:[]) -> do - fw_mxs <- lookup_mxs (BS.pack domain_part) - let norm_mxs = map (normalize . BS.pack) mxs - if (norm_mxs \\ fw_mxs) == [] then return False else return True - _ -> return True -- Report it if we can't figure out the domain. + -- If we don't normalize these first, comparison (isSubsetOf) + -- doesn't work so great. + mx_set = fromList (map normalize_string_domain mxs) + + -- We perform a lookup using a normalized key, so we'd better + -- normalize the keys in the map first! + normal_mxmap = mapKeys normalize_string_domain domain_mx_map + + is_bad :: Forward -> Bool + is_bad f = + case (address_domain f) of + Nothing -> False -- Do **NOT** drop these. + Just d -> case (Map.lookup (normalize_string_domain d) normal_mxmap) of + Nothing -> False -- No domain MX? Don't drop. + + -- We need to normalize the set of MXes for the + -- domain, too. + Just dmxs -> + let ndmxs = (Set.map normalize_string_domain dmxs) + in + ndmxs `isSubsetOf` mx_set -- | Given a connection and a 'Configuration', produces the report as @@ -220,11 +224,28 @@ report cfg conn = do domains <- get_domain_list conn (domain_query cfg) forwards <- get_forward_list conn (forward_query cfg) - valid_forwards <- filter_by_mx (exclude_mx cfg) forwards - let remote_forwards = find_remote_forwards domains valid_forwards - let forward_strings = map format_forward remote_forwards + -- valid_forwards are those not excluded based on their address's MXes. + -- + -- WARNING: Don't do MX lookups if the exclude list is empty! It + -- wastes a ton of time! + -- + -- Don't ask why, but this doesn't work if you factor out the + -- "return" below. + -- + let exclude_mx_list = exclude_mx cfg + valid_forwards <- if null (get_mxs exclude_mx_list) + then return forwards + else do + domain_mxs <- mx_set_map domains + return $ dropby_mxlist exclude_mx_list domain_mxs forwards + + let remote_forwards = dropby_goto_domains domains valid_forwards + let forward_strings = map pretty_print remote_forwards - return $ (join "\n" forward_strings) + -- Don't append the final newline if there's nothing to report. + return $ if (null forward_strings) + then "" + else (join "\n" forward_strings) ++ "\n" @@ -248,4 +269,4 @@ test_example1 = "user2@example.com -> user1@example.org\n" ++ "user2@example.com -> user2@example.org\n" ++ "user2@example.com -> user3@example.org\n" ++ - "user7@example.com -> user8@example.net" + "user7@example.com -> user8@example.net\n" -- 2.43.2