a189664e1ff8d199b3cd87bca91a46b97a3e0832
[list-remote-forwards.git] / src / Report.hs
1 {-# LANGUAGE PatternGuards #-}
2
3 module Report (
4 report,
5 report_tests )
6 where
7
8 import Control.Monad ( filterM )
9 import qualified Data.ByteString.Char8 as BS ( pack )
10 import Data.Maybe ( catMaybes, listToMaybe )
11 import Data.String.Utils ( join, split, strip )
12 import Database.HDBC (
13 IConnection,
14 execute,
15 prepare,
16 sFetchAllRows')
17 import Database.HDBC.Sqlite3 ( connectSqlite3 )
18 import Data.List ( (\\) )
19 import Network.DNS.Utils ( normalize )
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 ( lookup_mxs )
26 import MxList ( MxList(..) )
27
28 -- Type synonyms to make the signatures below a little more clear.
29 type Domain = String
30 type Address = String
31 type Goto = String
32
33 -- | A data type representing a "forward." That is, an email address
34 -- whose mail is sent to some other address.
35 --
36 -- The 'Address' field represents the alias address, the address to
37 -- which mail is sent. The 'Goto' field is the address to which the
38 -- mail is forwarded.
39 --
40 data Forward =
41 Forward Address Goto
42 deriving (Show)
43
44 -- | Given a connection @conn@ and a @query@, return a list of domains
45 -- found by executing @query@ on @conn. The @query@ is assumed to
46 -- return only one column, containing domains.
47 --
48 get_domain_list :: IConnection a
49 => a -- ^ A database connection
50 -> String -- ^ The @query@ to execute
51 -> IO [Domain] -- ^ The list of domains returned from @query@
52 get_domain_list conn query = do
53 stmt <- prepare conn query
54
55 -- We really want executeRaw here, but there's a bug: it will tell
56 -- us we can't fetch rows from the statement since it hasn't been
57 -- executed yet!
58 _ <- execute stmt []
59
60 -- rows :: [[Maybe String]]
61 rows <- sFetchAllRows' stmt
62
63 -- rows' :: [Maybe String]
64 let rows' = map (listToMaybe . catMaybes) rows
65
66 -- domains :: [String]
67 let domains = catMaybes rows'
68
69 return domains
70
71
72 -- | Convert a row obtained in 'get_forward_list' into a list of
73 -- 'Forward's. The row is assumed to have two columns, the first
74 -- with an address, and the second with a comma-separated list of
75 -- gotos.
76 --
77 -- We return a list containing one entry for each address, goto pair.
78 --
79 -- ==== __Examples__
80 --
81 -- A single address, pointed to itself (common with PostfixAdmin):
82 --
83 -- >>> let addr = "a@b.test"
84 -- >>> let gotos = "a@b.test"
85 -- >>> row_to_forwards [addr, gotos]
86 -- [Forward "a@b.test" "a@b.test"]
87 --
88 -- One address forwarded to two other addresses:
89 --
90 -- >>> let addr = "a@b.test"
91 -- >>> let gotos = "a1@b.test,a2@b.test"
92 -- >>> row_to_forwards [addr, gotos]
93 -- [Forward "a@b.test" "a1@b.test",Forward "a@b.test" "a2@b.test"]
94 --
95 -- An address that receives mail itself, but also forwards a copy to
96 -- another address (also common in PostfixAdmin). We've also mangled
97 -- the whitespace a little bit here:
98 --
99 -- >>> let addr = "a@b.test"
100 -- >>> let gotos = "a@b.test ,a2@b.test "
101 -- >>> row_to_forwards [addr, gotos]
102 -- [Forward "a@b.test" "a@b.test",Forward "a@b.test" "a2@b.test"]
103 --
104 -- And finally, a one-element list, which should return no forwards:
105 --
106 -- >>> let addr = "a@b.test"
107 -- >>> row_to_forwards [addr]
108 -- []
109 --
110 row_to_forwards :: [String] -> [Forward]
111 row_to_forwards (addr:gotos:_) =
112 [Forward addr (strip g) | g <- split "," gotos]
113 row_to_forwards _ = []
114
115
116 -- | Given a connection @conn@ and a @query@, return a list of
117 -- forwards found by executing @query@ on @conn. The @query@ is
118 -- assumed to return two columns, the first containing addresses and
119 -- the second containing a comma-separated list of gotos (as a
120 -- string).
121 --
122 get_forward_list :: IConnection a
123 => a -- ^ A database connection
124 -> String -- ^ The @query@ to execute
125 -> IO [Forward] -- ^ A list of forwards returned from @query@
126 get_forward_list conn query = do
127 stmt <- prepare conn query
128
129 -- We really want executeRaw here, but there's a bug: it will tell
130 -- us we can't fetch rows from the statement since it hasn't been
131 -- executed yet!
132 _ <- execute stmt []
133
134 -- rows :: [[Maybe String]]
135 rows <- sFetchAllRows' stmt
136
137 -- forwards :: [Forward]
138 let forwards = concatMap (row_to_forwards . catMaybes) rows
139
140 return forwards
141
142
143
144 -- | Given a list of local 'Domain's and a list of 'Forward's, filter
145 -- out all of the local forwards and return only the remaining
146 -- (remote) forwards.
147 --
148 -- ==== __Examples__
149 --
150 -- >>> let ds = ["example.com", "example.net"]
151 -- >>> let f1 = Forward "a@example.com" "a@example.com"
152 -- >>> let f2 = Forward "a@example.com" "a1@example.net"
153 -- >>> let f3 = Forward "a@example.com" "a2@example.org"
154 -- >>> find_remote_forwards ds [f1,f2,f3]
155 -- [Forward "a@example.com" "a2@example.org"]
156 --
157 find_remote_forwards :: [Domain] -> [Forward] -> [Forward]
158 find_remote_forwards domains forwards =
159 filter is_remote forwards
160 where
161 is_remote :: Forward -> Bool
162 is_remote (Forward _ goto) =
163 let parts = split "@" goto
164 in
165 case parts of
166 (_:dp:[]) -> not $ dp `elem` domains
167 _ -> True -- Assume it's remote if something is wrong
168
169
170 -- | Format a 'Forward' for pretty printing.
171 --
172 -- ==== __Examples__
173 --
174 -- >>> let fwd = Forward "a@example.com" "b@example.net"
175 -- >>> format_forward fwd
176 -- "a@example.com -> b@example.net"
177 --
178 format_forward :: Forward -> String
179 format_forward (Forward addr goto) =
180 addr ++ " -> " ++ goto
181
182
183
184 -- | A filter function to remove specific 'Forward's from a list (of
185 -- fowards). Its intended usage is to ignore a 'Forward' if its
186 -- 'Address' has an MX record contained in the given list. This
187 -- could be useful if, for example, one MX has strict spam filtering
188 -- and remote forwards are not a problem for domains with that MX.
189 --
190 -- If the MX records for a domain are exactly those contained in the
191 -- 'MxList', then we exclude that domain from the report. Splitting on
192 -- the '@' is a lazy way of obtaining the domain, but if it's good
193 -- enough for determining that a forward is remote, then it's good
194 -- enough for this.
195 --
196 -- The empty @MxList []@ special case is necessary! Otherwise if we
197 -- have an empty exclude list and a domain that has no MX record, it
198 -- will be excluded.
199 --
200 filter_by_mx :: MxList -> [Forward] -> IO [Forward]
201 filter_by_mx (MxList []) = return
202 filter_by_mx (MxList mxs) =
203 filterM all_mxs_excluded
204 where
205 all_mxs_excluded :: Forward -> IO Bool
206 all_mxs_excluded (Forward addr _) =
207 case (split "@" addr) of
208 (_:domain_part:[]) -> do
209 fw_mxs <- lookup_mxs (BS.pack domain_part)
210 let norm_mxs = map (normalize . BS.pack) mxs
211 if (norm_mxs \\ fw_mxs) == [] then return False else return True
212 _ -> return True -- Report it if we can't figure out the domain.
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 <- filter_by_mx (exclude_mx cfg) forwards
224 let remote_forwards = find_remote_forwards domains valid_forwards
225 let forward_strings = map format_forward remote_forwards
226
227 return $ (join "\n" forward_strings)
228
229
230
231 -- * Tests
232
233 report_tests :: TestTree
234 report_tests =
235 testGroup "Report Tests" [ test_example1 ]
236
237
238 test_example1 :: TestTree
239 test_example1 =
240 testCase desc $ do
241 conn <- connectSqlite3 "test/fixtures/postfixadmin.sqlite3"
242 let cfg = def :: Configuration
243 actual <- report cfg conn
244 actual @?= expected
245 where
246 desc = "all remote forwards are found"
247 expected = "user1@example.com -> user1@example.net\n" ++
248 "user2@example.com -> user1@example.org\n" ++
249 "user2@example.com -> user2@example.org\n" ++
250 "user2@example.com -> user3@example.org\n" ++
251 "user7@example.com -> user8@example.net"