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 -- | A data type representing a "forward." That is, an email address
  34 --   whose mail is sent to some other address.
  35 --
  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
  38 --   mail is forwarded.
  39 --
  40 data Forward =
  41   Forward Address Goto
  42   deriving (Show)
  43
  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.
  47 --
  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
  54
  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
  57   -- executed yet!
  58   _ <- execute stmt []
  59
  60   -- rows :: [[Maybe String]]
  61   rows <- sFetchAllRows' stmt
  62
  63   -- rows' :: [Maybe String]
  64   let rows' = map (listToMaybe . catMaybes) rows
  65
  66   -- domains :: [String]
  67   let domains = catMaybes rows'
  68
  69   return domains
  70
  71
  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
  75 --   gotos.
  76 --
  77 --   We return a list containing one entry for each address, goto pair.
  78 --
  79 --   ==== __Examples__
  80 --
  81 --   A single address, pointed to itself (common with PostfixAdmin):
  82 --
  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"]
  87 --
  88 --   One address forwarded to two other addresses:
  89 --
  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"]
  94 --
  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:
  98 --
  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"]
 103 --
 104 --   And finally, a one-element list, which should return no forwards:
 105 --
 106 --   >>> let addr = "a@b.test"
 107 --   >>> row_to_forwards [addr]
 108 --   []
 109 --
 110 row_to_forwards :: [String] -> [Forward]
 111 row_to_forwards (addr:gotos:_) =
 112   [Forward addr (strip g) | g <- split "," gotos]
 113 row_to_forwards _ = []
 114
 115
 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
 120 --   string).
 121 --
 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
 128
 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
 131   -- executed yet!
 132   _ <- execute stmt []
 133
 134   -- rows :: [[Maybe String]]
 135   rows <- sFetchAllRows' stmt
 136
 137   -- forwards :: [Forward]
 138   let forwards = concatMap (row_to_forwards . catMaybes) rows
 139
 140   return forwards
 141
 142
 143
 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.
 147 --
 148 --   ==== __Examples__
 149 --
 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"]
 156 --
 157 find_remote_forwards :: [Domain] -> [Forward] -> [Forward]
 158 find_remote_forwards domains forwards =
 159   filter is_remote forwards
 160   where
 161     is_remote :: Forward -> Bool
 162     is_remote (Forward _ goto) =
 163       let parts = split "@" goto
 164       in
 165         case parts of
 166           (_:dp:[]) -> not $ dp `elem` domains
 167           _        -> True -- Assume it's remote if something is wrong
 168
 169
 170 -- | Format a 'Forward' for pretty printing.
 171 --
 172 --   ==== __Examples__
 173 --
 174 --   >>> let fwd = Forward "a@example.com" "b@example.net"
 175 --   >>> format_forward fwd
 176 --   "a@example.com -> b@example.net"
 177 --
 178 format_forward :: Forward -> String
 179 format_forward (Forward addr goto) =
 180   addr ++ " -> " ++ goto
 181
 182
 183
 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.
 189 --
 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
 194 --   enough for this.
 195 --
 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
 198 --   will be excluded.
 199 --
 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
 204   where
 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.
 213
 214
 215 -- | Given a connection and a 'Configuration', produces the report as
 216 --   a 'String'.
 217 --
 218 report :: IConnection a => Configuration -> a -> IO String
 219 report cfg conn = do
 220   domains <- get_domain_list conn (domain_query cfg)
 221   forwards <- get_forward_list conn (forward_query cfg)
 222
 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
 226
 227   return $ (join "\n" forward_strings) ++ "\n"
 228
 229
 230
 231 -- * Tests
 232
 233 report_tests :: TestTree
 234 report_tests =
 235   testGroup "Report Tests" [ test_example1 ]
 236
 237
 238 test_example1 :: TestTree
 239 test_example1 =
 240   testCase desc $ do
 241     conn <- connectSqlite3 "test/fixtures/postfixadmin.sqlite3"
 242     let cfg = def :: Configuration
 243     actual <- report cfg conn
 244     actual @?= expected
 245   where
 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" ++
 251                "user7@example.com -> user8@example.net\n"