X-Git-Url: http://gitweb.michael.orlitzky.com/?p=list-remote-forwards.git;a=blobdiff_plain;f=src%2FReport.hs;h=efeaf65c3fb336d846bbaa2a44f8c9f1401d4e83;hp=5b3853350efc3a07c581ad20b354741c3d127cc5;hb=34d9cc7a2def43cb2d588ee3d1d405f0b9d4a1d0;hpb=f75845314598408bce3a1b972f2ba274d93d0e8d diff --git a/src/Report.hs b/src/Report.hs index 5b38533..efeaf65 100644 --- a/src/Report.hs +++ b/src/Report.hs @@ -1,18 +1,17 @@ -{-# LANGUAGE PatternGuards #-} - module Report ( report, report_tests ) 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, + Statement, execute, prepare, sFetchAllRows') @@ -27,6 +26,7 @@ import Forward ( Forward(..), address_domain, dropby_goto_domains, + fwd, pretty_print, strings_to_forwards ) import MxList ( MxList(..) ) @@ -35,6 +35,17 @@ import MxList ( MxList(..) ) -- WARNING: Also defined in the "Forward" module. type Domain = String + +-- | We really want executeRaw here, but there's a bug: it will tell +-- us we can't fetch rows from the statement since it hasn't been +-- executed yet! +-- +my_executeRaw :: Statement -> IO [[Maybe String]] +my_executeRaw stmt = do + _ <- execute stmt [] + sFetchAllRows' stmt + + -- | Given a connection @conn@ and a @query@, return a list of domains -- found by executing @query@ on @conn. The @query@ is assumed to -- return only one column, containing domains. @@ -45,14 +56,7 @@ get_domain_list :: IConnection a -> IO [Domain] -- ^ The list of domains returned from @query@ get_domain_list conn query = do stmt <- prepare conn query - - -- We really want executeRaw here, but there's a bug: it will tell - -- us we can't fetch rows from the statement since it hasn't been - -- executed yet! - _ <- execute stmt [] - - -- rows :: [[Maybe String]] - rows <- sFetchAllRows' stmt + rows <- my_executeRaw stmt -- rows' :: [Maybe String] let rows' = map (listToMaybe . catMaybes) rows @@ -77,14 +81,7 @@ get_forward_list :: IConnection a -> IO [Forward] -- ^ A list of forwards returned from @query@ get_forward_list conn query = do stmt <- prepare conn query - - -- We really want executeRaw here, but there's a bug: it will tell - -- us we can't fetch rows from the statement since it hasn't been - -- executed yet! - _ <- execute stmt [] - - -- rows :: [[Maybe String]] - rows <- sFetchAllRows' stmt + rows <- my_executeRaw stmt -- forwards :: [Forward] let forwards = concatMap (strings_to_forwards . catMaybes) rows @@ -125,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)] @@ -175,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 = @@ -195,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! @@ -253,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 @@ -270,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"