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