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,
Forward(..),
address_domain,
dropby_goto_domains,
+ fwd,
pretty_print,
strings_to_forwards )
import MxList ( MxList(..) )
-- 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_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)
+-- >>> 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)]
-- >>> 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 =
where
-- If we don't normalize these first, comparison (isSubsetOf)
-- doesn't work so great.
- mx_set = fromList (map normalize_string_domain mxs)
+ 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!
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
"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 ["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"]
+ let actual = dropby_mxlist 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 ["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"]
+ let actual = dropby_mxlist 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 example_mx_pairs = [("example.com.", 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 expected = fwds
+ actual @?= expected
+ where
+ desc = "dropby_mxlist requires all mx to be in the exclude list"
projects / list-remote-forwards.git / blobdiff