X-Git-Url: http://gitweb.michael.orlitzky.com/?p=list-remote-forwards.git;a=blobdiff_plain;f=src%2FReport.hs;h=efeaf65c3fb336d846bbaa2a44f8c9f1401d4e83;hp=bceeaf8b6a7faeadf6871fb552d1c921bb26be5b;hb=34d9cc7a2def43cb2d588ee3d1d405f0b9d4a1d0;hpb=8e5a377920002012c38066a2d21b6393a78c677a diff --git a/src/Report.hs b/src/Report.hs index bceeaf8..efeaf65 100644 --- a/src/Report.hs +++ b/src/Report.hs @@ -1,45 +1,50 @@ -{-# LANGUAGE PatternGuards #-} - module Report ( report, report_tests ) where -import Control.Monad ( filterM ) -import qualified Data.ByteString.Char8 as BS ( pack ) +import Data.Map ( mapKeys ) +import qualified Data.Map as Map ( fromList, lookup ) import Data.Maybe ( catMaybes, listToMaybe ) -import Data.String.Utils ( join, split, strip ) +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') import Database.HDBC.Sqlite3 ( connectSqlite3 ) -import Data.List ( (\\) ) -import Network.DNS.Utils ( normalize ) import System.Console.CmdArgs.Default ( Default(..) ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Configuration ( Configuration(..) ) -import DNS ( lookup_mxs ) +import DNS ( MxSetMap, mx_set_map, normalize_string_domain ) +import Forward ( + Forward(..), + address_domain, + dropby_goto_domains, + fwd, + pretty_print, + strings_to_forwards ) import MxList ( MxList(..) ) --- Type synonyms to make the signatures below a little more clear. +-- | Type synonym to make the signatures below a little more clear. +-- WARNING: Also defined in the "Forward" module. type Domain = String -type Address = String -type Goto = String --- | A data type representing a "forward." That is, an email address --- whose mail is sent to some other address. --- --- The 'Address' field represents the alias address, the address to --- which mail is sent. The 'Goto' field is the address to which the --- mail is forwarded. + +-- | 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! -- -data Forward = - Forward Address Goto - deriving (Show) +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 @@ -51,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 @@ -69,48 +67,6 @@ get_domain_list conn query = do return domains --- | Convert a row obtained in 'get_forward_list' into a list of --- 'Forward's. The row is assumed to have two columns, the first --- with an address, and the second with a comma-separated list of --- gotos. --- --- We return a list containing one entry for each address, goto pair. --- --- ==== __Examples__ --- --- A single address, pointed to itself (common with PostfixAdmin): --- --- >>> let addr = "a@b.test" --- >>> let gotos = "a@b.test" --- >>> row_to_forwards [addr, gotos] --- [Forward "a@b.test" "a@b.test"] --- --- One address forwarded to two other addresses: --- --- >>> let addr = "a@b.test" --- >>> let gotos = "a1@b.test,a2@b.test" --- >>> row_to_forwards [addr, gotos] --- [Forward "a@b.test" "a1@b.test",Forward "a@b.test" "a2@b.test"] --- --- An address that receives mail itself, but also forwards a copy to --- another address (also common in PostfixAdmin). We've also mangled --- the whitespace a little bit here: --- --- >>> let addr = "a@b.test" --- >>> let gotos = "a@b.test ,a2@b.test " --- >>> row_to_forwards [addr, gotos] --- [Forward "a@b.test" "a@b.test",Forward "a@b.test" "a2@b.test"] --- --- And finally, a one-element list, which should return no forwards: --- --- >>> let addr = "a@b.test" --- >>> row_to_forwards [addr] --- [] --- -row_to_forwards :: [String] -> [Forward] -row_to_forwards (addr:gotos:_) = - [Forward addr (strip g) | g <- split "," gotos] -row_to_forwards _ = [] -- | Given a connection @conn@ and a @query@, return a list of @@ -125,91 +81,93 @@ 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 (row_to_forwards . catMaybes) rows + let forwards = concatMap (strings_to_forwards . catMaybes) rows return forwards --- | Given a list of local 'Domain's and a list of 'Forward's, filter --- out all of the local forwards and return only the remaining --- (remote) forwards. +-- | A filter function to remove specific 'Forward's from a list (of +-- forwards). Its intended usage is to ignore a 'Forward' if its +-- 'Address' has MX records that are all contained in the given +-- list. This could be useful if, for example, one MX has strict +-- spam filtering and remote forwards are not a problem for domains +-- with that MX. -- --- ==== __Examples__ +-- If the MX records for a domain are contained in the 'MxList', +-- then we exclude that domain from the report. -- --- >>> let ds = ["example.com", "example.net"] --- >>> let f1 = Forward "a@example.com" "a@example.com" --- >>> let f2 = Forward "a@example.com" "a1@example.net" --- >>> let f3 = Forward "a@example.com" "a2@example.org" --- >>> find_remote_forwards ds [f1,f2,f3] --- [Forward "a@example.com" "a2@example.org"] +-- For performance reasons, we want to have precomputed the MX +-- records for all of the address domains in our list of +-- forwards. We do this so we don't look up the MX records twice for +-- two addresses within the same domain. We could just as well do +-- this within this function, but by taking the @domain_mxs@ as a +-- parameter, we allow ourselves to be a pure function. -- -find_remote_forwards :: [Domain] -> [Forward] -> [Forward] -find_remote_forwards domains forwards = - filter is_remote forwards - where - is_remote :: Forward -> Bool - is_remote (Forward _ goto) = - let parts = split "@" goto - in - case parts of - (_:dp:[]) -> not $ dp `elem` domains - _ -> True -- Assume it's remote if something is wrong - - --- | Format a 'Forward' for pretty printing. +-- If the domain of a forward address can't be determined, it won't +-- be dropped! This is intentional: the existence of a forward +-- address without a domain part probably indicates a configuration +-- error somewhere, and we should report it. +-- +-- The empty @MxList []@ special case is necessary! Otherwise if we +-- have an empty exclude list and a domain that has no MX record, it +-- will be excluded. -- -- ==== __Examples__ -- --- >>> let fwd = Forward "a@example.com" "b@example.net" --- >>> format_forward fwd --- "a@example.com -> b@example.net" +-- Our single forward should be dropped from the list, because its +-- MX record list, ["mx.example.com"], is contained in the list of +-- excluded MXs: -- -format_forward :: Forward -> String -format_forward (Forward addr goto) = - addr ++ " -> " ++ goto - - - --- | A filter function to remove specific 'Forward's from a list (of --- fowards). Its intended usage is to ignore a 'Forward' if its --- 'Address' has an MX record contained in the given list. This --- could be useful if, for example, one MX has strict spam filtering --- and remote forwards are not a problem for domains with that MX. +-- >>> 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"] +-- >>> dropby_mxlist droplist mx_map fwds +-- [] -- --- If the MX records for a domain are exactly those contained in the --- 'MxList', then we exclude that domain from the report. Splitting on --- the '@' is a lazy way of obtaining the domain, but if it's good --- enough for determining that a forward is remote, then it's good --- enough for this. +-- This time it shouldn't be dropped, because ["mx.example.com"] is +-- not contained in ["nope.example.com"]: -- --- The empty @MxList []@ special case is necessary! Otherwise if we --- have an empty exclude list and a domain that has no MX record, it --- will be excluded. +-- >>> 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 ["nope.example.com"] +-- >>> map pretty_print (dropby_mxlist droplist mx_map fwds) +-- ["user1@example.com -> user2@example.net"] -- -filter_by_mx :: MxList -> [Forward] -> IO [Forward] -filter_by_mx (MxList []) = return -filter_by_mx (MxList mxs) = - filterM all_mxs_excluded +dropby_mxlist :: MxList -> MxSetMap -> [Forward] -> [Forward] +dropby_mxlist (MxList []) _ = id +dropby_mxlist (MxList mxs) domain_mx_map = + filter (not . is_bad) where - all_mxs_excluded :: Forward -> IO Bool - all_mxs_excluded (Forward addr _) = - case (split "@" addr) of - (_:domain_part:[]) -> do - fw_mxs <- lookup_mxs (BS.pack domain_part) - let norm_mxs = map (normalize . BS.pack) mxs - if (norm_mxs \\ fw_mxs) == [] then return False else return True - _ -> return True -- Report it if we can't figure out the domain. + -- 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 + + 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 + Nothing -> False -- No domain MX? Don't drop. + + -- 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 @@ -220,11 +178,28 @@ report cfg conn = do domains <- get_domain_list conn (domain_query cfg) forwards <- get_forward_list conn (forward_query cfg) - valid_forwards <- filter_by_mx (exclude_mx cfg) forwards - let remote_forwards = find_remote_forwards domains valid_forwards - let forward_strings = map format_forward remote_forwards + -- valid_forwards are those not excluded based on their address's MXes. + -- + -- WARNING: Don't do MX lookups if the exclude list is empty! It + -- wastes a ton of time! + -- + -- 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) + then return forwards + else do + domain_mxs <- mx_set_map domains + return $ dropby_mxlist exclude_mx_list domain_mxs forwards - return $ (join "\n" forward_strings) ++ "\n" + let remote_forwards = dropby_goto_domains domains valid_forwards + let forward_strings = map pretty_print remote_forwards + + -- Don't append the final newline if there's nothing to report. + return $ if (null forward_strings) + then "" + else (join "\n" forward_strings) ++ "\n" @@ -232,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 @@ -247,4 +227,59 @@ test_example1 = expected = "user1@example.com -> user1@example.net\n" ++ "user2@example.com -> user1@example.org\n" ++ "user2@example.com -> user2@example.org\n" ++ - "user2@example.com -> user3@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"