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