Change some doctest examples into unit tests.

diff --git a/src/Forward.hs b/src/Forward.hs
index 3e9ad88fba5c0275443e1934034685ce5423739c..8d977fac299e46017850efdcc625fa99a9001ca3 100644 (file)
--- a/src/Forward.hs
+++ b/src/Forward.hs
@@ -22,14 +22,14 @@ type Domain = String
 --   a 'String'. This differs from a 'Goto' in that it should only
 --   appear on the left-hand-side of a alias -> goto relationship.
 --
-newtype Address = Address String deriving ( Show )
+newtype Address = Address String deriving ( Eq, Show )
 
 
 -- | A type-safe wrapper around an email address that's represented as
 --   a 'String'. This differs from 'Address' in that 'Goto' addresses
 --   are the destinations of mail that is forwarded, rather than the
 --   source.
-newtype Goto = Goto String deriving ( Show )
+newtype Goto = Goto String deriving ( Eq, Show )
 
 
 -- | A data type representing a "forward." That is, an email address
@@ -41,7 +41,7 @@ newtype Goto = Goto String deriving ( Show )
 --
 data Forward =
   Forward Address Goto
-  deriving (Show)
+  deriving ( Eq, Show )
 
 
 -- | Shortcut constructor for creating 'Forward' objects.

diff --git a/src/Report.hs b/src/Report.hs
index dd3ce4e9ae5d698c7d9985c2e32f7e937a10f2dd..efeaf65c3fb336d846bbaa2a44f8c9f1401d4e83 100644 (file)
--- a/src/Report.hs
+++ b/src/Report.hs
@@ -4,10 +4,10 @@ module Report (
 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,
@@ -26,6 +26,7 @@ import Forward (
   Forward(..),
   address_domain,
   dropby_goto_domains,
+  fwd,
   pretty_print,
   strings_to_forwards )
 import MxList ( MxList(..) )
@@ -121,48 +122,18 @@ 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_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)]
@@ -171,19 +142,6 @@ get_forward_list conn query = do
 --   >>> 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 =
@@ -191,7 +149,7 @@ 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!
@@ -249,7 +207,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 +229,57 @@ 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 ["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"