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"