82409c42ef95a71b7fd346520cc3c85e40805d2b
[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 data Forward =
34 Forward Address Goto
35 deriving (Show)
36
37 get_domain_list :: IConnection a => a -> String -> IO [Domain]
38 get_domain_list conn query = do
39 stmt <- prepare conn query
40
41 -- We really want executeRaw here, but there's a bug: it will tell
42 -- us we can't fetch rows from the statement since it hasn't been
43 -- executed yet!
44 _ <- execute stmt []
45
46 -- rows :: [[Maybe String]]
47 rows <- sFetchAllRows' stmt
48
49 -- rows' :: [Maybe String]
50 let rows' = map (listToMaybe . catMaybes) rows
51
52 -- domains :: [String]
53 let domains = catMaybes rows'
54
55 return domains
56
57
58 get_forward_list :: IConnection a => a -> String -> IO [Forward]
59 get_forward_list conn query = do
60 stmt <- prepare conn query
61
62 -- We really want executeRaw here, but there's a bug: it will tell
63 -- us we can't fetch rows from the statement since it hasn't been
64 -- executed yet!
65 _ <- execute stmt []
66
67 -- rows :: [[Maybe String]]
68 rows <- sFetchAllRows' stmt
69
70 -- forwards :: [Forward]
71 let forwards = concatMap (row_to_forwards . catMaybes) rows
72
73 return forwards
74 where
75 row_to_forwards :: [String] -> [Forward]
76 row_to_forwards (addr:gotos:_) =
77 [Forward addr (strip g) | g <- split "," gotos]
78 row_to_forwards _ = []
79
80
81
82 find_remote_forwards :: [Domain] -> [Forward] -> [Forward]
83 find_remote_forwards domains forwards =
84 filter is_remote forwards
85 where
86 is_remote :: Forward -> Bool
87 is_remote (Forward _ goto) =
88 let parts = split "@" goto
89 in
90 case parts of
91 (_:dp:[]) -> not $ dp `elem` domains
92 _ -> True -- Assume it's remote if something is wrong
93
94
95 format_forward :: Forward -> String
96 format_forward (Forward addr goto) =
97 addr ++ " -> " ++ goto
98
99
100 -- If the MX records for a domain are exactly those contained in the
101 -- MxList, then we exclude that domain from the report. Splitting on
102 -- the '@' is a lazy way of obtaining the domain, but if it's good
103 -- enough for determining that a forward is remote, then it's good
104 -- enough for this.
105 filter_by_mx :: MxList -> [Forward] -> IO [Forward]
106 -- This special case is necessary! Otherwise if we have an empty
107 -- exclude list and a domain that has no MX record, it will be
108 -- excluded.
109 filter_by_mx (MxList []) = return
110 filter_by_mx (MxList mxs) =
111 filterM all_mxs_excluded
112 where
113 all_mxs_excluded :: Forward -> IO Bool
114 all_mxs_excluded (Forward addr _) =
115 case (split "@" addr) of
116 (_:domain_part:[]) -> do
117 fw_mxs <- lookup_mxs (BS.pack domain_part)
118 let norm_mxs = map (normalize . BS.pack) mxs
119 if (norm_mxs \\ fw_mxs) == [] then return False else return True
120 _ -> return True -- Report it if we can't figure out the domain.
121
122
123 -- | Given a connection and a 'Configuration', produces the report as
124 -- a 'String'.
125 --
126 report :: IConnection a => Configuration -> a -> IO String
127 report cfg conn = do
128 domains <- get_domain_list conn (domain_query cfg)
129 forwards <- get_forward_list conn (forward_query cfg)
130
131 valid_forwards <- filter_by_mx (exclude_mx cfg) forwards
132 let remote_forwards = find_remote_forwards domains valid_forwards
133 let forward_strings = map format_forward remote_forwards
134
135 return $ (join "\n" forward_strings) ++ "\n"
136
137
138
139 -- * Tests
140
141 report_tests :: TestTree
142 report_tests =
143 testGroup "Report Tests" [ test_example1 ]
144
145
146 test_example1 :: TestTree
147 test_example1 =
148 testCase desc $ do
149 conn <- connectSqlite3 "test/fixtures/postfixadmin.sqlite3"
150 let cfg = def :: Configuration
151 actual <- report cfg conn
152 actual @?= expected
153 where
154 desc = "all remote forwards are found"
155 expected = "user1@example.com -> user1@example.net\n" ++
156 "user2@example.com -> user1@example.org\n" ++
157 "user2@example.com -> user2@example.org\n" ++
158 "user2@example.com -> user3@example.org\n"