-{-# LANGUAGE PatternGuards #-}
-
module Report (
report,
report_tests )
where
-import Control.Monad ( filterM )
-import qualified Data.ByteString.Char8 as BS ( pack )
+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 System.Console.CmdArgs.Default ( Default(..) )
+import System.Console.CmdArgs.Default ( Default( def ) )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
-import Configuration ( Configuration(..) )
-import DNS ( lookup_mxs, normalize )
-import MxList ( MxList(..) )
-
--- Type synonyms to make the signatures below a little more clear.
+import Configuration ( Configuration( domain_query,
+ exclude_mx,
+ forward_query) )
+import DNS (
+ MxSetMap,
+ NormalDomain,
+ mx_set_map,
+ normalize_string )
+import Forward (
+ Forward(),
+ address_domain,
+ dropby_goto_domains,
+ fwd,
+ pretty_print,
+ strings_to_forwards )
+import MxList ( MxList( get_mxs ) )
+
+-- | 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
-data Forward =
- Forward Address Goto
- deriving (Show)
-get_domain_list :: IConnection a => a -> String -> IO [Domain]
-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!
+-- | 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
- -- rows :: [[Maybe String]]
- rows <- 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.
+--
+get_domain_list :: IConnection a
+ => a -- ^ A database connection
+ -> String -- ^ The @query@ to execute
+ -> IO [Domain] -- ^ The list of domains returned from @query@
+get_domain_list conn query = do
+ stmt <- prepare conn query
+ rows <- my_executeRaw stmt
-- rows' :: [Maybe String]
let rows' = map (listToMaybe . catMaybes) rows
return domains
-get_forward_list :: IConnection a => a -> String -> IO [Forward]
-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
+-- | Given a connection @conn@ and a @query@, return a list of
+-- forwards found by executing @query@ on @conn. The @query@ is
+-- assumed to return two columns, the first containing addresses and
+-- the second containing a comma-separated list of gotos (as a
+-- string).
+--
+get_forward_list :: IConnection a
+ => a -- ^ A database connection
+ -> String -- ^ The @query@ to execute
+ -> IO [Forward] -- ^ A list of forwards returned from @query@
+get_forward_list conn query = do
+ stmt <- prepare conn query
+ rows <- my_executeRaw stmt
-- forwards :: [Forward]
- let forwards = concatMap (row_to_forwards . catMaybes) rows
+ let forwards = concatMap (strings_to_forwards . catMaybes) rows
return forwards
- where
- row_to_forwards :: [String] -> [Forward]
- row_to_forwards (addr:gotos:_) =
- [Forward addr (strip g) | g <- split "," gotos]
- row_to_forwards _ = []
-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_forward :: Forward -> String
-format_forward (Forward addr goto) =
- addr ++ " -> " ++ goto
-
-
--- 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.
-filter_by_mx :: MxList -> [Forward] -> IO [Forward]
--- This special case is necessary! Otherwise if we have an empty
--- exclude list and a domain that has no MX record, it will be
--- excluded.
-filter_by_mx (MxList []) = return
-filter_by_mx (MxList mxs) =
- filterM all_mxs_excluded
+-- | 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.
+--
+-- If the MX records for a domain are contained in the 'MxList',
+-- then we exclude that domain from the report.
+--
+-- 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.
+--
+-- 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__
+--
+-- 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:
+--
+-- >>> import Forward ( fwd )
+-- >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
+-- >>> 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 = ["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 [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 = ["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 :: [NormalDomain] -> MxSetMap -> [Forward] -> [Forward]
+dropby_mxlist [] _ = id
+dropby_mxlist normal_mxs 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.
+ 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 d) mx_map) of
+ Nothing -> False -- No domain MX? Don't drop.
+ Just dmxs -> dmxs `isSubsetOf` mx_set
+
-- | Given a connection and a 'Configuration', produces the report as
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
-
- return $ (join "\n" forward_strings) ++ "\n"
+ -- 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 = 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
+
+ -- 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.
+ return $ if (null forward_strings)
+ then ""
+ else (join "\n" forward_strings) ++ "\n"
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
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 [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 = ["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
+ 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 [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 = ["mx.EXAMple.com", "mx2.example.COM"]
+ let normal_droplist = map normalize_string droplist
+ let actual = dropby_mxlist normal_droplist mx_map fwds
+ let expected = [] :: [Forward]
+ 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 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 = ["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
+ desc = "dropby_mxlist requires all mx to be in the exclude list"