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