Get things in shape finally:
[list-remote-forwards.git] / src / Report.hs
1 {-# LANGUAGE PatternGuards #-}
2
3 module Report (
4 report,
5 report_tests )
6 where
7
8 import Data.Map ( mapKeys )
9 import qualified Data.Map as Map ( lookup )
10 import Data.Maybe ( catMaybes, listToMaybe )
11 import Data.Set ( fromList, isSubsetOf )
12 import qualified Data.Set as Set ( map )
13 import Data.String.Utils ( join )
14 import Database.HDBC (
15 IConnection,
16 execute,
17 prepare,
18 sFetchAllRows')
19 import Database.HDBC.Sqlite3 ( connectSqlite3 )
20 import System.Console.CmdArgs.Default ( Default(..) )
21 import Test.Tasty ( TestTree, testGroup )
22 import Test.Tasty.HUnit ( (@?=), testCase )
23
24 import Configuration ( Configuration(..) )
25 import DNS ( MxSetMap, mx_set_map, normalize_string_domain )
26 import Forward (
27 Forward(..),
28 address_domain,
29 dropby_goto_domains,
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 -- | Given a connection @conn@ and a @query@, return a list of domains
39 -- found by executing @query@ on @conn. The @query@ is assumed to
40 -- return only one column, containing domains.
41 --
42 get_domain_list :: IConnection a
43 => a -- ^ A database connection
44 -> String -- ^ The @query@ to execute
45 -> IO [Domain] -- ^ The list of domains returned from @query@
46 get_domain_list conn query = do
47 stmt <- prepare conn query
48
49 -- We really want executeRaw here, but there's a bug: it will tell
50 -- us we can't fetch rows from the statement since it hasn't been
51 -- executed yet!
52 _ <- execute stmt []
53
54 -- rows :: [[Maybe String]]
55 rows <- sFetchAllRows' stmt
56
57 -- rows' :: [Maybe String]
58 let rows' = map (listToMaybe . catMaybes) rows
59
60 -- domains :: [String]
61 let domains = catMaybes rows'
62
63 return domains
64
65
66
67
68 -- | Given a connection @conn@ and a @query@, return a list of
69 -- forwards found by executing @query@ on @conn. The @query@ is
70 -- assumed to return two columns, the first containing addresses and
71 -- the second containing a comma-separated list of gotos (as a
72 -- string).
73 --
74 get_forward_list :: IConnection a
75 => a -- ^ A database connection
76 -> String -- ^ The @query@ to execute
77 -> IO [Forward] -- ^ A list of forwards returned from @query@
78 get_forward_list conn query = do
79 stmt <- prepare conn query
80
81 -- We really want executeRaw here, but there's a bug: it will tell
82 -- us we can't fetch rows from the statement since it hasn't been
83 -- executed yet!
84 _ <- execute stmt []
85
86 -- rows :: [[Maybe String]]
87 rows <- sFetchAllRows' 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 qualified Data.Map as Map ( fromList )
129 -- >>> import qualified Data.Set as Set ( fromList )
130 -- >>> import Forward ( fwd )
131 -- >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
132 -- >>> let mx_set = Set.fromList ["mx.example.com"]
133 -- >>> let example_mx_pairs = [("example.com.", mx_set)]
134 -- >>> let mx_map = Map.fromList example_mx_pairs
135 -- >>> let droplist = MxList ["mx.example.com", "mx2.example.com"]
136 -- >>> map pretty_print (dropby_mxlist droplist mx_map fwds)
137 -- []
138 --
139 -- Repeat the previous test with the goto domain, to make sure we're
140 -- dropping based on the address and not the goto:
141 --
142 -- >>> import qualified Data.Map as Map ( fromList )
143 -- >>> import qualified Data.Set as Set ( fromList )
144 -- >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
145 -- >>> let mx_set = Set.fromList ["mx.example.net"]
146 -- >>> let example_mx_pairs = [("example.net.", mx_set)]
147 -- >>> let mx_map = Map.fromList example_mx_pairs
148 -- >>> let droplist = MxList ["mx.example.net", "mx2.example.net"]
149 -- >>> map pretty_print (dropby_mxlist droplist mx_map fwds)
150 -- ["user1@example.com -> user2@example.net"]
151 --
152 -- Use weird caps, and optional trailing dot all over the place to
153 -- make sure everything is handled normalized:
154 --
155 -- >>> import qualified Data.Set as Set ( fromList )
156 -- >>> import Forward ( fwd )
157 -- >>> let fwds = [fwd "user1@exAmPle.com." "user2@examPle.net"]
158 -- >>> let mx_set = Set.fromList ["mx.EXAMPLE.com"]
159 -- >>> let example_mx_pairs = [("Example.com", mx_set)]
160 -- >>> let mx_map = Map.fromList example_mx_pairs
161 -- >>> let droplist = MxList ["mx.EXAMple.com", "mx2.example.COM"]
162 -- >>> map pretty_print (dropby_mxlist droplist mx_map fwds)
163 -- []
164 --
165 -- This time it shouldn't be dropped, because ["mx.example.com"] is
166 -- not contained in ["nope.example.com"]:
167 --
168 -- >>> import qualified Data.Map as Map ( fromList )
169 -- >>> import qualified Data.Set as Set ( fromList )
170 -- >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
171 -- >>> let mx_set = Set.fromList ["mx.example.com"]
172 -- >>> let example_mx_pairs = [("example.com.", mx_set)]
173 -- >>> let mx_map = Map.fromList example_mx_pairs
174 -- >>> let droplist = MxList ["nope.example.com"]
175 -- >>> map pretty_print (dropby_mxlist droplist mx_map fwds)
176 -- ["user1@example.com -> user2@example.net"]
177 --
178 -- Now we check that if a forward has two MXes, one of which appears
179 -- in the list of excluded MXes, it doesn't get dropped:
180 --
181 -- >>> import qualified Data.Map as Map ( fromList )
182 -- >>> import qualified Data.Set as Set ( fromList )
183 -- >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
184 -- >>> let mx_set = Set.fromList ["mx1.example.com", "mx2.example.com"]
185 -- >>> let example_mx_pairs = [("example.com.", mx_set)]
186 -- >>> let mx_map = Map.fromList example_mx_pairs
187 -- >>> let droplist = MxList ["mx1.example.com"]
188 -- >>> map pretty_print (dropby_mxlist droplist mx_map fwds)
189 -- ["user1@example.com -> user2@example.net"]
190 --
191 dropby_mxlist :: MxList -> MxSetMap -> [Forward] -> [Forward]
192 dropby_mxlist (MxList []) _ = id
193 dropby_mxlist (MxList mxs) domain_mx_map =
194 filter (not . is_bad)
195 where
196 -- If we don't normalize these first, comparison (isSubsetOf)
197 -- doesn't work so great.
198 mx_set = fromList (map normalize_string_domain mxs)
199
200 -- We perform a lookup using a normalized key, so we'd better
201 -- normalize the keys in the map first!
202 normal_mxmap = mapKeys normalize_string_domain domain_mx_map
203
204 is_bad :: Forward -> Bool
205 is_bad f =
206 case (address_domain f) of
207 Nothing -> False -- Do **NOT** drop these.
208 Just d -> case (Map.lookup (normalize_string_domain d) normal_mxmap) of
209 Nothing -> False -- No domain MX? Don't drop.
210
211 -- We need to normalize the set of MXes for the
212 -- domain, too.
213 Just dmxs ->
214 let ndmxs = (Set.map normalize_string_domain dmxs)
215 in
216 ndmxs `isSubsetOf` mx_set
217
218
219 -- | Given a connection and a 'Configuration', produces the report as
220 -- a 'String'.
221 --
222 report :: IConnection a => Configuration -> a -> IO String
223 report cfg conn = do
224 domains <- get_domain_list conn (domain_query cfg)
225 forwards <- get_forward_list conn (forward_query cfg)
226
227 -- valid_forwards are those not excluded based on their address's MXes.
228 --
229 -- WARNING: Don't do MX lookups if the exclude list is empty! It
230 -- wastes a ton of time!
231 --
232 -- Don't ask why, but this doesn't work if you factor out the
233 -- "return" below.
234 --
235 let exclude_mx_list = exclude_mx cfg
236 valid_forwards <- if null (get_mxs exclude_mx_list)
237 then return forwards
238 else do
239 domain_mxs <- mx_set_map domains
240 return $ dropby_mxlist exclude_mx_list domain_mxs forwards
241
242 let remote_forwards = dropby_goto_domains domains valid_forwards
243 let forward_strings = map pretty_print remote_forwards
244
245 -- Don't append the final newline if there's nothing to report.
246 return $ if (null forward_strings)
247 then ""
248 else (join "\n" forward_strings) ++ "\n"
249
250
251
252 -- * Tests
253
254 report_tests :: TestTree
255 report_tests =
256 testGroup "Report Tests" [ test_example1 ]
257
258
259 test_example1 :: TestTree
260 test_example1 =
261 testCase desc $ do
262 conn <- connectSqlite3 "test/fixtures/postfixadmin.sqlite3"
263 let cfg = def :: Configuration
264 actual <- report cfg conn
265 actual @?= expected
266 where
267 desc = "all remote forwards are found"
268 expected = "user1@example.com -> user1@example.net\n" ++
269 "user2@example.com -> user1@example.org\n" ++
270 "user2@example.com -> user2@example.org\n" ++
271 "user2@example.com -> user3@example.org\n" ++
272 "user7@example.com -> user8@example.net\n"