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"