X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FReport.hs;h=0f77f511448014e3a05572da885be4f94f29650a;hb=HEAD;hp=efeaf65c3fb336d846bbaa2a44f8c9f1401d4e83;hpb=34d9cc7a2def43cb2d588ee3d1d405f0b9d4a1d0;p=list-remote-forwards.git diff --git a/src/Report.hs b/src/Report.hs index efeaf65..0f77f51 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 ) @@ -16,20 +15,26 @@ import Database.HDBC ( prepare, sFetchAllRows') import Database.HDBC.Sqlite3 ( connectSqlite3 ) -import System.Console.CmdArgs.Default ( Default(..) ) +import System.Console.CmdArgs.Default ( Default( def ) ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) -import Configuration ( Configuration(..) ) -import DNS ( MxSetMap, mx_set_map, normalize_string_domain ) +import Configuration ( Configuration( domain_query, + exclude_mx, + forward_query) ) +import DNS ( + MxSetMap, + NormalDomain, + mx_set_map, + normalize_string ) import Forward ( - Forward(..), + Forward(), address_domain, dropby_goto_domains, fwd, pretty_print, strings_to_forwards ) -import MxList ( MxList(..) ) +import MxList ( MxList( get_mxs ) ) -- | Type synonym to make the signatures below a little more clear. -- WARNING: Also defined in the "Forward" module. @@ -124,50 +129,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 +182,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 +236,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,12 +255,13 @@ 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 expected = [] + 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 = [] :: [Forward] actual @?= expected where desc = "dropby_mxlist only performs comparisons on normalized names" @@ -275,10 +276,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