Introduce a NormalDomain newtype to ensure comparisons are made safely.
[list-remote-forwards.git] / src / Report.hs
1 module Report (
2 report,
3 report_tests )
4 where
5
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 (
12 IConnection,
13 Statement,
14 execute,
15 prepare,
16 sFetchAllRows')
17 import Database.HDBC.Sqlite3 ( connectSqlite3 )
18 import System.Console.CmdArgs.Default ( Default(..) )
19 import Test.Tasty ( TestTree, testGroup )
20 import Test.Tasty.HUnit ( (@?=), testCase )
21
22 import Configuration ( Configuration(..) )
23 import DNS (
24 MxSetMap,
25 NormalDomain,
26 mx_set_map,
27 normalize_string )
28 import Forward (
29 Forward(..),
30 address_domain,
31 dropby_goto_domains,
32 fwd,
33 pretty_print,
34 strings_to_forwards )
35 import MxList ( MxList(..) )
36
37 -- | Type synonym to make the signatures below a little more clear.
38 -- WARNING: Also defined in the "Forward" module.
39 type Domain = String
40
41
42 -- | We really want executeRaw here, but there's a bug: it will tell
43 -- us we can't fetch rows from the statement since it hasn't been
44 -- executed yet!
45 --
46 my_executeRaw :: Statement -> IO [[Maybe String]]
47 my_executeRaw stmt = do
48 _ <- execute stmt []
49 sFetchAllRows' stmt
50
51
52 -- | Given a connection @conn@ and a @query@, return a list of domains
53 -- found by executing @query@ on @conn. The @query@ is assumed to
54 -- return only one column, containing domains.
55 --
56 get_domain_list :: IConnection a
57 => a -- ^ A database connection
58 -> String -- ^ The @query@ to execute
59 -> IO [Domain] -- ^ The list of domains returned from @query@
60 get_domain_list conn query = do
61 stmt <- prepare conn query
62 rows <- my_executeRaw stmt
63
64 -- rows' :: [Maybe String]
65 let rows' = map (listToMaybe . catMaybes) rows
66
67 -- domains :: [String]
68 let domains = catMaybes rows'
69
70 return domains
71
72
73
74
75 -- | Given a connection @conn@ and a @query@, return a list of
76 -- forwards found by executing @query@ on @conn. The @query@ is
77 -- assumed to return two columns, the first containing addresses and
78 -- the second containing a comma-separated list of gotos (as a
79 -- string).
80 --
81 get_forward_list :: IConnection a
82 => a -- ^ A database connection
83 -> String -- ^ The @query@ to execute
84 -> IO [Forward] -- ^ A list of forwards returned from @query@
85 get_forward_list conn query = do
86 stmt <- prepare conn query
87 rows <- my_executeRaw stmt
88
89 -- forwards :: [Forward]
90 let forwards = concatMap (strings_to_forwards . catMaybes) rows
91
92 return forwards
93
94
95
96 -- | A filter function to remove specific 'Forward's from a list (of
97 -- forwards). Its intended usage is to ignore a 'Forward' if its
98 -- 'Address' has MX records that are all contained in the given
99 -- list. This could be useful if, for example, one MX has strict
100 -- spam filtering and remote forwards are not a problem for domains
101 -- with that MX.
102 --
103 -- If the MX records for a domain are contained in the 'MxList',
104 -- then we exclude that domain from the report.
105 --
106 -- For performance reasons, we want to have precomputed the MX
107 -- records for all of the address domains in our list of
108 -- forwards. We do this so we don't look up the MX records twice for
109 -- two addresses within the same domain. We could just as well do
110 -- this within this function, but by taking the @domain_mxs@ as a
111 -- parameter, we allow ourselves to be a pure function.
112 --
113 -- If the domain of a forward address can't be determined, it won't
114 -- be dropped! This is intentional: the existence of a forward
115 -- address without a domain part probably indicates a configuration
116 -- error somewhere, and we should report it.
117 --
118 -- The empty @MxList []@ special case is necessary! Otherwise if we
119 -- have an empty exclude list and a domain that has no MX record, it
120 -- will be excluded.
121 --
122 -- ==== __Examples__
123 --
124 -- Our single forward should be dropped from the list, because its
125 -- MX record list, ["mx.example.com"], is contained in the list of
126 -- excluded MXs:
127 --
128 -- >>> import Forward ( fwd )
129 -- >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
130 -- >>> let mx_set = Set.fromList [normalize_string "mx.example.com"]
131 -- >>> let example_mx_pairs = [(normalize_string "example.com.", mx_set)]
132 -- >>> let mx_map = Map.fromList example_mx_pairs
133 -- >>> let droplist = ["mx.example.com", "mx2.example.com"]
134 -- >>> let normal_droplist = map normalize_string droplist
135 -- >>> dropby_mxlist normal_droplist mx_map fwds
136 -- []
137 --
138 -- This time it shouldn't be dropped, because ["mx.example.com"] is
139 -- not contained in ["nope.example.com"]:
140 --
141 -- >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
142 -- >>> let mx_set = Set.fromList [normalize_string "mx.example.com"]
143 -- >>> let example_mx_pairs = [(normalize_string "example.com.", mx_set)]
144 -- >>> let mx_map = Map.fromList example_mx_pairs
145 -- >>> let droplist = ["nope.example.com"]
146 -- >>> let normal_droplist = map normalize_string droplist
147 -- >>> map pretty_print (dropby_mxlist normal_droplist mx_map fwds)
148 -- ["user1@example.com -> user2@example.net"]
149 --
150 dropby_mxlist :: [NormalDomain] -> MxSetMap -> [Forward] -> [Forward]
151 dropby_mxlist [] _ = id
152 dropby_mxlist normal_mxs mx_map =
153 filter (not . is_bad)
154 where
155 mx_set = Set.fromList normal_mxs
156
157 is_bad :: Forward -> Bool
158 is_bad f =
159 case (address_domain f) of
160 Nothing -> False -- Do **NOT** drop these.
161 Just d -> case (Map.lookup (normalize_string d) mx_map) of
162 Nothing -> False -- No domain MX? Don't drop.
163 Just dmxs -> dmxs `isSubsetOf` mx_set
164
165
166
167 -- | Given a connection and a 'Configuration', produces the report as
168 -- a 'String'.
169 --
170 report :: IConnection a => Configuration -> a -> IO String
171 report cfg conn = do
172 domains <- get_domain_list conn (domain_query cfg)
173 forwards <- get_forward_list conn (forward_query cfg)
174
175 -- valid_forwards are those not excluded based on their address's MXes.
176 --
177 -- WARNING: Don't do MX lookups if the exclude list is empty! It
178 -- wastes a ton of time!
179 --
180 -- Don't ask why, but this doesn't work if you factor out the
181 -- "return" below.
182 --
183 let exclude_mx_list = map normalize_string (get_mxs $ exclude_mx cfg)
184 valid_forwards <- if (null exclude_mx_list)
185 then return forwards
186 else do
187 domain_mxs <- mx_set_map domains
188 return $ dropby_mxlist exclude_mx_list domain_mxs forwards
189
190 -- We need to normalize our domain names before we can pass them to
191 -- dropby_goto_domains.
192 let normal_domains = map normalize_string domains
193 let remote_forwards = dropby_goto_domains normal_domains valid_forwards
194 let forward_strings = map pretty_print remote_forwards
195
196 -- Don't append the final newline if there's nothing to report.
197 return $ if (null forward_strings)
198 then ""
199 else (join "\n" forward_strings) ++ "\n"
200
201
202
203 -- * Tests
204
205 report_tests :: TestTree
206 report_tests =
207 testGroup
208 "Report Tests"
209 [ test_example1,
210 test_dropby_mxlist_affects_address,
211 test_dropby_mxlist_compares_normalized,
212 test_dropby_mxlist_requires_subset ]
213
214
215 test_example1 :: TestTree
216 test_example1 =
217 testCase desc $ do
218 conn <- connectSqlite3 "test/fixtures/postfixadmin.sqlite3"
219 let cfg = def :: Configuration
220 actual <- report cfg conn
221 actual @?= expected
222 where
223 desc = "all remote forwards are found"
224 expected = "user1@example.com -> user1@example.net\n" ++
225 "user2@example.com -> user1@example.org\n" ++
226 "user2@example.com -> user2@example.org\n" ++
227 "user2@example.com -> user3@example.org\n" ++
228 "user7@example.com -> user8@example.net\n"
229
230
231 -- | Make sure we're dropping based on the address and not the goto.
232 --
233 test_dropby_mxlist_affects_address :: TestTree
234 test_dropby_mxlist_affects_address =
235 testCase desc $ do
236 let fwds = [fwd "user1@example.com" "user2@example.net"]
237 let mx_set = Set.fromList [normalize_string "mx.example.net"]
238 let example_mx_pairs = [(normalize_string "example.net.", mx_set)]
239 let mx_map = Map.fromList example_mx_pairs
240 let droplist = ["mx.example.net", "mx2.example.net"]
241 let normal_droplist = map normalize_string droplist
242 let actual = dropby_mxlist normal_droplist mx_map fwds
243 let expected = fwds
244 actual @?= expected
245 where
246 desc = "dropby_mxlist affects the \"address\" and not the \"goto"
247
248
249 -- | Use weird caps, and optional trailing dot all over the place to
250 -- make sure everything is handled normalized.
251 --
252 test_dropby_mxlist_compares_normalized :: TestTree
253 test_dropby_mxlist_compares_normalized =
254 testCase desc $ do
255 let fwds = [fwd "user1@exAmPle.com." "user2@examPle.net"]
256 let mx_set = Set.fromList [normalize_string "mx.EXAMPLE.com"]
257 let example_mx_pairs = [(normalize_string "Example.com", mx_set)]
258 let mx_map = Map.fromList example_mx_pairs
259 let droplist = ["mx.EXAMple.com", "mx2.example.COM"]
260 let normal_droplist = map normalize_string droplist
261 let actual = dropby_mxlist normal_droplist mx_map fwds
262 let expected = []
263 actual @?= expected
264 where
265 desc = "dropby_mxlist only performs comparisons on normalized names"
266
267
268
269 -- | Check that if a forward has two MXes, only one of which appears
270 -- in the list of excluded MXes, it doesn't get dropped.
271 --
272 test_dropby_mxlist_requires_subset :: TestTree
273 test_dropby_mxlist_requires_subset =
274 testCase desc $ do
275 let fwds = [fwd "user1@example.com" "user2@example.net"]
276 let mx_set = Set.fromList ["mx1.example.com", "mx2.example.com"]
277 let normal_mx_set = Set.map normalize_string mx_set
278 let example_mx_pairs = [(normalize_string "example.com.", normal_mx_set)]
279 let mx_map = Map.fromList example_mx_pairs
280 let droplist = ["mx1.example.com"]
281 let normal_droplist = map normalize_string droplist
282 let actual = dropby_mxlist normal_droplist mx_map fwds
283 let expected = fwds
284 actual @?= expected
285 where
286 desc = "dropby_mxlist requires all mx to be in the exclude list"