1 {-# LANGUAGE PatternGuards #-}
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 (
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 )
24 import Configuration ( Configuration(..) )
25 import DNS ( lookup_mxs )
26 import MxList ( MxList(..) )
28 -- Type synonyms to make the signatures below a little more clear.
33 -- | A data type representing a "forward." That is, an email address
34 -- whose mail is sent to some other address.
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
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.
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
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
60 -- rows :: [[Maybe String]]
61 rows <- sFetchAllRows' stmt
63 -- rows' :: [Maybe String]
64 let rows' = map (listToMaybe . catMaybes) rows
66 -- domains :: [String]
67 let domains = catMaybes rows'
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
77 -- We return a list containing one entry for each address, goto pair.
81 -- A single address, pointed to itself (common with PostfixAdmin):
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"]
88 -- One address forwarded to two other addresses:
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"]
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:
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"]
104 -- And finally, a one-element list, which should return no forwards:
106 -- >>> let addr = "a@b.test"
107 -- >>> row_to_forwards [addr]
110 row_to_forwards :: [String] -> [Forward]
111 row_to_forwards (addr:gotos:_) =
112 [Forward addr (strip g) | g <- split "," gotos]
113 row_to_forwards _ = []
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
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
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
134 -- rows :: [[Maybe String]]
135 rows <- sFetchAllRows' stmt
137 -- forwards :: [Forward]
138 let forwards = concatMap (row_to_forwards . catMaybes) rows
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.
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"]
157 find_remote_forwards :: [Domain] -> [Forward] -> [Forward]
158 find_remote_forwards domains forwards =
159 filter is_remote forwards
161 is_remote :: Forward -> Bool
162 is_remote (Forward _ goto) =
163 let parts = split "@" goto
166 (_:dp:[]) -> not $ dp `elem` domains
167 _ -> True -- Assume it's remote if something is wrong
170 -- | Format a 'Forward' for pretty printing.
174 -- >>> let fwd = Forward "a@example.com" "b@example.net"
175 -- >>> format_forward fwd
176 -- "a@example.com -> b@example.net"
178 format_forward :: Forward -> String
179 format_forward (Forward addr goto) =
180 addr ++ " -> " ++ goto
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.
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
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
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
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.
215 -- | Given a connection and a 'Configuration', produces the report as
218 report :: IConnection a => Configuration -> a -> IO String
220 domains <- get_domain_list conn (domain_query cfg)
221 forwards <- get_forward_list conn (forward_query cfg)
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
227 return $ (join "\n" forward_strings) ++ "\n"
233 report_tests :: TestTree
235 testGroup "Report Tests" [ test_example1 ]
238 test_example1 :: TestTree
241 conn <- connectSqlite3 "test/fixtures/postfixadmin.sqlite3"
242 let cfg = def :: Configuration
243 actual <- report cfg conn
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"