6 import qualified Data.Map as Map ( fromList, lookup )
7 import Data.Maybe ( catMaybes, listToMaybe )
8 import Data.Set ( isSubsetOf )
9 import qualified Data.Set as Set ( fromList, map )
10 import Data.String.Utils ( join )
11 import Database.HDBC (
17 import Database.HDBC.Sqlite3 ( connectSqlite3 )
18 import System.Console.CmdArgs.Default ( Default( def ) )
19 import Test.Tasty ( TestTree, testGroup )
20 import Test.Tasty.HUnit ( (@?=), testCase )
22 import Configuration ( Configuration( domain_query,
37 import MxList ( MxList( get_mxs ) )
39 -- | Type synonym to make the signatures below a little more clear.
40 -- WARNING: Also defined in the "Forward" module.
44 -- | We really want executeRaw here, but there's a bug: it will tell
45 -- us we can't fetch rows from the statement since it hasn't been
48 my_executeRaw :: Statement -> IO [[Maybe String]]
49 my_executeRaw stmt = do
54 -- | Given a connection @conn@ and a @query@, return a list of domains
55 -- found by executing @query@ on @conn. The @query@ is assumed to
56 -- return only one column, containing domains.
58 get_domain_list :: IConnection a
59 => a -- ^ A database connection
60 -> String -- ^ The @query@ to execute
61 -> IO [Domain] -- ^ The list of domains returned from @query@
62 get_domain_list conn query = do
63 stmt <- prepare conn query
64 rows <- my_executeRaw stmt
66 -- rows' :: [Maybe String]
67 let rows' = map (listToMaybe . catMaybes) rows
69 -- domains :: [String]
70 let domains = catMaybes rows'
77 -- | Given a connection @conn@ and a @query@, return a list of
78 -- forwards found by executing @query@ on @conn. The @query@ is
79 -- assumed to return two columns, the first containing addresses and
80 -- the second containing a comma-separated list of gotos (as a
83 get_forward_list :: IConnection a
84 => a -- ^ A database connection
85 -> String -- ^ The @query@ to execute
86 -> IO [Forward] -- ^ A list of forwards returned from @query@
87 get_forward_list conn query = do
88 stmt <- prepare conn query
89 rows <- my_executeRaw stmt
91 -- forwards :: [Forward]
92 let forwards = concatMap (strings_to_forwards . catMaybes) rows
98 -- | A filter function to remove specific 'Forward's from a list (of
99 -- forwards). Its intended usage is to ignore a 'Forward' if its
100 -- 'Address' has MX records that are all contained in the given
101 -- list. This could be useful if, for example, one MX has strict
102 -- spam filtering and remote forwards are not a problem for domains
105 -- If the MX records for a domain are contained in the 'MxList',
106 -- then we exclude that domain from the report.
108 -- For performance reasons, we want to have precomputed the MX
109 -- records for all of the address domains in our list of
110 -- forwards. We do this so we don't look up the MX records twice for
111 -- two addresses within the same domain. We could just as well do
112 -- this within this function, but by taking the @domain_mxs@ as a
113 -- parameter, we allow ourselves to be a pure function.
115 -- If the domain of a forward address can't be determined, it won't
116 -- be dropped! This is intentional: the existence of a forward
117 -- address without a domain part probably indicates a configuration
118 -- error somewhere, and we should report it.
120 -- The empty @MxList []@ special case is necessary! Otherwise if we
121 -- have an empty exclude list and a domain that has no MX record, it
126 -- Our single forward should be dropped from the list, because its
127 -- MX record list, ["mx.example.com"], is contained in the list of
130 -- >>> import Forward ( fwd )
131 -- >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
132 -- >>> let mx_set = Set.fromList [normalize_string "mx.example.com"]
133 -- >>> let example_mx_pairs = [(normalize_string "example.com.", mx_set)]
134 -- >>> let mx_map = Map.fromList example_mx_pairs
135 -- >>> let droplist = ["mx.example.com", "mx2.example.com"]
136 -- >>> let normal_droplist = map normalize_string droplist
137 -- >>> dropby_mxlist normal_droplist mx_map fwds
140 -- This time it shouldn't be dropped, because ["mx.example.com"] is
141 -- not contained in ["nope.example.com"]:
143 -- >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
144 -- >>> let mx_set = Set.fromList [normalize_string "mx.example.com"]
145 -- >>> let example_mx_pairs = [(normalize_string "example.com.", mx_set)]
146 -- >>> let mx_map = Map.fromList example_mx_pairs
147 -- >>> let droplist = ["nope.example.com"]
148 -- >>> let normal_droplist = map normalize_string droplist
149 -- >>> map pretty_print (dropby_mxlist normal_droplist mx_map fwds)
150 -- ["user1@example.com -> user2@example.net"]
152 dropby_mxlist :: [NormalDomain] -> MxSetMap -> [Forward] -> [Forward]
153 dropby_mxlist [] _ = id
154 dropby_mxlist normal_mxs mx_map =
155 filter (not . is_bad)
157 mx_set = Set.fromList normal_mxs
159 is_bad :: Forward -> Bool
161 case (address_domain f) of
162 Nothing -> False -- Do **NOT** drop these.
163 Just d -> case (Map.lookup (normalize_string d) mx_map) of
164 Nothing -> False -- No domain MX? Don't drop.
165 Just dmxs -> dmxs `isSubsetOf` mx_set
169 -- | Given a connection and a 'Configuration', produces the report as
172 report :: IConnection a => Configuration -> a -> IO String
174 domains <- get_domain_list conn (domain_query cfg)
175 forwards <- get_forward_list conn (forward_query cfg)
177 -- valid_forwards are those not excluded based on their address's MXes.
179 -- WARNING: Don't do MX lookups if the exclude list is empty! It
180 -- wastes a ton of time!
182 -- Don't ask why, but this doesn't work if you factor out the
185 let exclude_mx_list = map normalize_string (get_mxs $ exclude_mx cfg)
186 valid_forwards <- if (null exclude_mx_list)
189 domain_mxs <- mx_set_map domains
190 return $ dropby_mxlist exclude_mx_list domain_mxs forwards
192 -- We need to normalize our domain names before we can pass them to
193 -- dropby_goto_domains.
194 let normal_domains = map normalize_string domains
195 let remote_forwards = dropby_goto_domains normal_domains valid_forwards
196 let forward_strings = map pretty_print remote_forwards
198 -- Don't append the final newline if there's nothing to report.
199 return $ if (null forward_strings)
201 else (join "\n" forward_strings) ++ "\n"
207 report_tests :: TestTree
212 test_dropby_mxlist_affects_address,
213 test_dropby_mxlist_compares_normalized,
214 test_dropby_mxlist_requires_subset ]
217 test_example1 :: TestTree
220 conn <- connectSqlite3 "test/fixtures/postfixadmin.sqlite3"
221 let cfg = def :: Configuration
222 actual <- report cfg conn
225 desc = "all remote forwards are found"
226 expected = "user1@example.com -> user1@example.net\n" ++
227 "user2@example.com -> user1@example.org\n" ++
228 "user2@example.com -> user2@example.org\n" ++
229 "user2@example.com -> user3@example.org\n" ++
230 "user7@example.com -> user8@example.net\n"
233 -- | Make sure we're dropping based on the address and not the goto.
235 test_dropby_mxlist_affects_address :: TestTree
236 test_dropby_mxlist_affects_address =
238 let fwds = [fwd "user1@example.com" "user2@example.net"]
239 let mx_set = Set.fromList [normalize_string "mx.example.net"]
240 let example_mx_pairs = [(normalize_string "example.net.", mx_set)]
241 let mx_map = Map.fromList example_mx_pairs
242 let droplist = ["mx.example.net", "mx2.example.net"]
243 let normal_droplist = map normalize_string droplist
244 let actual = dropby_mxlist normal_droplist mx_map fwds
248 desc = "dropby_mxlist affects the \"address\" and not the \"goto"
251 -- | Use weird caps, and optional trailing dot all over the place to
252 -- make sure everything is handled normalized.
254 test_dropby_mxlist_compares_normalized :: TestTree
255 test_dropby_mxlist_compares_normalized =
257 let fwds = [fwd "user1@exAmPle.com." "user2@examPle.net"]
258 let mx_set = Set.fromList [normalize_string "mx.EXAMPLE.com"]
259 let example_mx_pairs = [(normalize_string "Example.com", mx_set)]
260 let mx_map = Map.fromList example_mx_pairs
261 let droplist = ["mx.EXAMple.com", "mx2.example.COM"]
262 let normal_droplist = map normalize_string droplist
263 let actual = dropby_mxlist normal_droplist mx_map fwds
264 let expected = [] :: [Forward]
267 desc = "dropby_mxlist only performs comparisons on normalized names"
271 -- | Check that if a forward has two MXes, only one of which appears
272 -- in the list of excluded MXes, it doesn't get dropped.
274 test_dropby_mxlist_requires_subset :: TestTree
275 test_dropby_mxlist_requires_subset =
277 let fwds = [fwd "user1@example.com" "user2@example.net"]
278 let mx_set = Set.fromList ["mx1.example.com", "mx2.example.com"]
279 let normal_mx_set = Set.map normalize_string mx_set
280 let example_mx_pairs = [(normalize_string "example.com.", normal_mx_set)]
281 let mx_map = Map.fromList example_mx_pairs
282 let droplist = ["mx1.example.com"]
283 let normal_droplist = map normalize_string droplist
284 let actual = dropby_mxlist normal_droplist mx_map fwds
288 desc = "dropby_mxlist requires all mx to be in the exclude list"