report_tests )
where
-import Data.Map ( mapKeys )
import qualified Data.Map as Map ( fromList, lookup )
import Data.Maybe ( catMaybes, listToMaybe )
import Data.Set ( isSubsetOf )
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,
--
-- >>> 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
-- 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.
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
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
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
projects / list-remote-forwards.git / blobdiff