X-Git-Url: http://gitweb.michael.orlitzky.com/?p=list-remote-forwards.git;a=blobdiff_plain;f=src%2FReport.hs;h=82dd07bc8750944fc9e2f8c526005d4f3e9f69a3;hp=dd3ce4e9ae5d698c7d9985c2e32f7e937a10f2dd;hb=e6d84b7f4768775949f6539b251b3ac54ccb0fd0;hpb=ae4cdbc0662d67d3d325c8ab567e0d45a84413b3 diff --git a/src/Report.hs b/src/Report.hs index dd3ce4e..82dd07b 100644 --- a/src/Report.hs +++ b/src/Report.hs @@ -3,11 +3,10 @@ module Report ( report_tests ) where -import Data.Map ( mapKeys ) -import qualified Data.Map as Map ( lookup ) +import qualified Data.Map as Map ( fromList, lookup ) import Data.Maybe ( catMaybes, listToMaybe ) -import Data.Set ( fromList, isSubsetOf ) -import qualified Data.Set as Set ( map ) +import Data.Set ( isSubsetOf ) +import qualified Data.Set as Set ( fromList, map ) import Data.String.Utils ( join ) import Database.HDBC ( IConnection, @@ -21,11 +20,16 @@ import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Configuration ( Configuration(..) ) -import DNS ( MxSetMap, mx_set_map, normalize_string_domain ) +import DNS ( + MxSetMap, + NormalDomain, + mx_set_map, + normalize_string ) import Forward ( Forward(..), address_domain, dropby_goto_domains, + fwd, pretty_print, strings_to_forwards ) import MxList ( MxList(..) ) @@ -121,95 +125,43 @@ get_forward_list conn query = do -- MX record list, ["mx.example.com"], is contained in the list of -- excluded MXs: -- --- >>> 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_set = Set.fromList [normalize_string "mx.example.com"] +-- >>> let example_mx_pairs = [(normalize_string "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) --- [] --- --- Repeat the previous test with the goto domain, to make sure we're --- dropping based on the address and not the goto: --- --- >>> 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"] --- --- 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) +-- >>> let droplist = ["mx.example.com", "mx2.example.com"] +-- >>> let normal_droplist = map normalize_string droplist +-- >>> dropby_mxlist normal_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_set = Set.fromList [normalize_string "mx.example.com"] +-- >>> let example_mx_pairs = [(normalize_string "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) +-- >>> let droplist = ["nope.example.com"] +-- >>> let normal_droplist = map normalize_string droplist +-- >>> map pretty_print (dropby_mxlist normal_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 = +dropby_mxlist :: [NormalDomain] -> MxSetMap -> [Forward] -> [Forward] +dropby_mxlist [] _ = id +dropby_mxlist normal_mxs mx_map = filter (not . is_bad) where - -- 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 + mx_set = Set.fromList normal_mxs 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 + Just d -> case (Map.lookup (normalize_string d) mx_map) of Nothing -> False -- No domain MX? Don't drop. + Just dmxs -> dmxs `isSubsetOf` mx_set - -- 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 @@ -228,14 +180,17 @@ report cfg conn = do -- 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) + let exclude_mx_list = map normalize_string (get_mxs $ exclude_mx cfg) + valid_forwards <- if (null 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 + -- We need to normalize our domain names before we can pass them to + -- dropby_goto_domains. + let normal_domains = map normalize_string domains + let remote_forwards = dropby_goto_domains normal_domains valid_forwards let forward_strings = map pretty_print remote_forwards -- Don't append the final newline if there's nothing to report. @@ -249,7 +204,12 @@ report cfg conn = do report_tests :: TestTree report_tests = - testGroup "Report Tests" [ test_example1 ] + testGroup + "Report Tests" + [ test_example1, + test_dropby_mxlist_affects_address, + test_dropby_mxlist_compares_normalized, + test_dropby_mxlist_requires_subset ] test_example1 :: TestTree @@ -266,3 +226,61 @@ test_example1 = "user2@example.com -> user2@example.org\n" ++ "user2@example.com -> user3@example.org\n" ++ "user7@example.com -> user8@example.net\n" + + +-- | Make sure we're dropping based on the address and not the goto. +-- +test_dropby_mxlist_affects_address :: TestTree +test_dropby_mxlist_affects_address = + testCase desc $ do + let fwds = [fwd "user1@example.com" "user2@example.net"] + let mx_set = Set.fromList [normalize_string "mx.example.net"] + let example_mx_pairs = [(normalize_string "example.net.", mx_set)] + let mx_map = Map.fromList example_mx_pairs + let droplist = ["mx.example.net", "mx2.example.net"] + let normal_droplist = map normalize_string droplist + let actual = dropby_mxlist normal_droplist mx_map fwds + let expected = fwds + actual @?= expected + where + desc = "dropby_mxlist affects the \"address\" and not the \"goto" + + +-- | Use weird caps, and optional trailing dot all over the place to +-- make sure everything is handled normalized. +-- +test_dropby_mxlist_compares_normalized :: TestTree +test_dropby_mxlist_compares_normalized = + testCase desc $ do + let fwds = [fwd "user1@exAmPle.com." "user2@examPle.net"] + let mx_set = Set.fromList [normalize_string "mx.EXAMPLE.com"] + let example_mx_pairs = [(normalize_string "Example.com", mx_set)] + let mx_map = Map.fromList example_mx_pairs + let droplist = ["mx.EXAMple.com", "mx2.example.COM"] + let normal_droplist = map normalize_string droplist + let actual = dropby_mxlist normal_droplist mx_map fwds + let expected = [] + actual @?= expected + where + desc = "dropby_mxlist only performs comparisons on normalized names" + + + +-- | Check that if a forward has two MXes, only one of which appears +-- in the list of excluded MXes, it doesn't get dropped. +-- +test_dropby_mxlist_requires_subset :: TestTree +test_dropby_mxlist_requires_subset = + testCase desc $ do + let fwds = [fwd "user1@example.com" "user2@example.net"] + let mx_set = Set.fromList ["mx1.example.com", "mx2.example.com"] + let normal_mx_set = Set.map normalize_string mx_set + let example_mx_pairs = [(normalize_string "example.com.", normal_mx_set)] + let mx_map = Map.fromList example_mx_pairs + let droplist = ["mx1.example.com"] + let normal_droplist = map normalize_string droplist + let actual = dropby_mxlist normal_droplist mx_map fwds + let expected = fwds + actual @?= expected + where + desc = "dropby_mxlist requires all mx to be in the exclude list"