module Report ( report, report_tests ) where import qualified Data.Map as Map ( fromList, lookup ) import Data.Maybe ( catMaybes, listToMaybe ) 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 System.Console.CmdArgs.Default ( Default(..) ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Configuration ( Configuration(..) ) 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(..) ) -- | Type synonym to make the signatures below a little more clear. -- 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. -- 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 -- domains :: [String] let domains = catMaybes rows' return domains -- | 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 (strings_to_forwards . catMaybes) rows return 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. -- -- 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 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 -- a 'String'. -- report :: IConnection a => Configuration -> a -> IO String report cfg conn = do domains <- get_domain_list conn (domain_query cfg) forwards <- get_forward_list conn (forward_query cfg) -- 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" -- * Tests report_tests :: TestTree report_tests = testGroup "Report Tests" [ test_example1, test_dropby_mxlist_affects_address, test_dropby_mxlist_compares_normalized, test_dropby_mxlist_requires_subset ] test_example1 :: TestTree test_example1 = testCase desc $ do conn <- connectSqlite3 "test/fixtures/postfixadmin.sqlite3" let cfg = def :: Configuration actual <- report cfg conn actual @?= expected where desc = "all remote forwards are found" 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" ++ "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 = [] 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"