X-Git-Url: http://gitweb.michael.orlitzky.com/?p=list-remote-forwards.git;a=blobdiff_plain;f=src%2FReport.hs;h=82dd07bc8750944fc9e2f8c526005d4f3e9f69a3;hp=efeaf65c3fb336d846bbaa2a44f8c9f1401d4e83;hb=66345cef9e56c6175cb6f25f41fbf628648d15a3;hpb=34d9cc7a2def43cb2d588ee3d1d405f0b9d4a1d0 diff --git a/src/Report.hs b/src/Report.hs index efeaf65..82dd07b 100644 --- a/src/Report.hs +++ b/src/Report.hs @@ -3,7 +3,6 @@ module Report ( report_tests ) where -import Data.Map ( mapKeys ) import qualified Data.Map as Map ( fromList, lookup ) import Data.Maybe ( catMaybes, listToMaybe ) import Data.Set ( isSubsetOf ) @@ -21,7 +20,11 @@ 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, @@ -124,50 +127,41 @@ get_forward_list conn query = do -- -- >>> 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"] --- >>> 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"]: -- -- >>> 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"] -- -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 = 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 @@ -186,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. @@ -237,11 +234,12 @@ 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 ["mx.example.net"] - let example_mx_pairs = [("example.net.", mx_set)] + 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 = MxList ["mx.example.net", "mx2.example.net"] - let actual = dropby_mxlist droplist mx_map fwds + 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 @@ -255,11 +253,12 @@ 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 ["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"] - let actual = dropby_mxlist droplist mx_map fwds + 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 @@ -275,10 +274,12 @@ 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 example_mx_pairs = [("example.com.", mx_set)] + 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 = MxList ["mx1.example.com"] - let actual = dropby_mxlist droplist mx_map fwds + 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