src/Report.hs

   1 module Report (
   2   report,
   3   report_tests )
   4 where
   5
   6 import qualified Data.Map as Map ( fromList, lookup )
   7 import Data.Maybe ( catMaybes, listToMaybe )
   8 import Data.Set ( isSubsetOf )
   9 import qualified Data.Set as Set ( fromList, map )
  10 import Data.String.Utils ( join )
  11 import Database.HDBC (
  12   IConnection,
  13   Statement,
  14   execute,
  15   prepare,
  16   sFetchAllRows')
  17 import Database.HDBC.Sqlite3 ( connectSqlite3 )
  18 import System.Console.CmdArgs.Default ( Default(..) )
  19 import Test.Tasty ( TestTree, testGroup )
  20 import Test.Tasty.HUnit ( (@?=), testCase )
  21
  22 import Configuration ( Configuration(..) )
  23 import DNS (
  24   MxSetMap,
  25   NormalDomain,
  26   mx_set_map,
  27   normalize_string )
  28 import Forward (
  29   Forward(..),
  30   address_domain,
  31   dropby_goto_domains,
  32   fwd,
  33   pretty_print,
  34   strings_to_forwards )
  35 import MxList ( MxList(..) )
  36
  37 -- | Type synonym to make the signatures below a little more clear.
  38 --   WARNING: Also defined in the "Forward" module.
  39 type Domain = String
  40
  41
  42 -- | We really want executeRaw here, but there's a bug: it will tell
  43 --   us we can't fetch rows from the statement since it hasn't been
  44 --   executed yet!
  45 --
  46 my_executeRaw :: Statement -> IO [[Maybe String]]
  47 my_executeRaw stmt = do
  48   _ <- execute stmt []
  49   sFetchAllRows' stmt
  50
  51
  52 -- | Given a connection @conn@ and a @query@, return a list of domains
  53 --   found by executing @query@ on @conn. The @query@ is assumed to
  54 --   return only one column, containing domains.
  55 --
  56 get_domain_list :: IConnection a
  57                 => a -- ^ A database connection
  58                 -> String -- ^ The @query@ to execute
  59                 -> IO [Domain] -- ^ The list of domains returned from @query@
  60 get_domain_list conn query = do
  61   stmt <- prepare conn query
  62   rows <- my_executeRaw stmt
  63
  64   -- rows' :: [Maybe String]
  65   let rows' = map (listToMaybe . catMaybes) rows
  66
  67   -- domains :: [String]
  68   let domains = catMaybes rows'
  69
  70   return domains
  71
  72
  73
  74
  75 -- | Given a connection @conn@ and a @query@, return a list of
  76 --   forwards found by executing @query@ on @conn. The @query@ is
  77 --   assumed to return two columns, the first containing addresses and
  78 --   the second containing a comma-separated list of gotos (as a
  79 --   string).
  80 --
  81 get_forward_list :: IConnection a
  82                  => a  -- ^ A database connection
  83                  -> String -- ^ The @query@ to execute
  84                  -> IO [Forward]  -- ^ A list of forwards returned from @query@
  85 get_forward_list conn query = do
  86   stmt <- prepare conn query
  87   rows <- my_executeRaw stmt
  88
  89   -- forwards :: [Forward]
  90   let forwards = concatMap (strings_to_forwards . catMaybes) rows
  91
  92   return forwards
  93
  94
  95
  96 -- | A filter function to remove specific 'Forward's from a list (of
  97 --   forwards).  Its intended usage is to ignore a 'Forward' if its
  98 --   'Address' has MX records that are all contained in the given
  99 --   list. This could be useful if, for example, one MX has strict
 100 --   spam filtering and remote forwards are not a problem for domains
 101 --   with that MX.
 102 --
 103 --   If the MX records for a domain are contained in the 'MxList',
 104 --   then we exclude that domain from the report.
 105 --
 106 --   For performance reasons, we want to have precomputed the MX
 107 --   records for all of the address domains in our list of
 108 --   forwards. We do this so we don't look up the MX records twice for
 109 --   two addresses within the same domain. We could just as well do
 110 --   this within this function, but by taking the @domain_mxs@ as a
 111 --   parameter, we allow ourselves to be a pure function.
 112 --
 113 --   If the domain of a forward address can't be determined, it won't
 114 --   be dropped! This is intentional: the existence of a forward
 115 --   address without a domain part probably indicates a configuration
 116 --   error somewhere, and we should report it.
 117 --
 118 --   The empty @MxList []@ special case is necessary! Otherwise if we
 119 --   have an empty exclude list and a domain that has no MX record, it
 120 --   will be excluded.
 121 --
 122 --   ==== __Examples__
 123 --
 124 --   Our single forward should be dropped from the list, because its
 125 --   MX record list, ["mx.example.com"], is contained in the list of
 126 --   excluded MXs:
 127 --
 128 --   >>> import Forward ( fwd )
 129 --   >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
 130 --   >>> let mx_set = Set.fromList [normalize_string "mx.example.com"]
 131 --   >>> let example_mx_pairs = [(normalize_string "example.com.", mx_set)]
 132 --   >>> let mx_map = Map.fromList example_mx_pairs
 133 --   >>> let droplist = ["mx.example.com", "mx2.example.com"]
 134 --   >>> let normal_droplist = map normalize_string droplist
 135 --   >>> dropby_mxlist normal_droplist mx_map fwds
 136 --   []
 137 --
 138 --   This time it shouldn't be dropped, because ["mx.example.com"] is
 139 --   not contained in ["nope.example.com"]:
 140 --
 141 --   >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
 142 --   >>> let mx_set = Set.fromList [normalize_string "mx.example.com"]
 143 --   >>> let example_mx_pairs = [(normalize_string "example.com.", mx_set)]
 144 --   >>> let mx_map = Map.fromList example_mx_pairs
 145 --   >>> let droplist = ["nope.example.com"]
 146 --   >>> let normal_droplist = map normalize_string droplist
 147 --   >>> map pretty_print (dropby_mxlist normal_droplist mx_map fwds)
 148 --   ["user1@example.com -> user2@example.net"]
 149 --
 150 dropby_mxlist :: [NormalDomain] -> MxSetMap -> [Forward] -> [Forward]
 151 dropby_mxlist [] _ = id
 152 dropby_mxlist normal_mxs mx_map =
 153   filter (not . is_bad)
 154   where
 155     mx_set = Set.fromList normal_mxs
 156
 157     is_bad :: Forward -> Bool
 158     is_bad f =
 159       case (address_domain f) of
 160         Nothing -> False -- Do **NOT** drop these.
 161         Just d  -> case (Map.lookup (normalize_string d) mx_map) of
 162                      Nothing -> False -- No domain MX? Don't drop.
 163                      Just dmxs -> dmxs `isSubsetOf` mx_set
 164
 165
 166
 167 -- | Given a connection and a 'Configuration', produces the report as
 168 --   a 'String'.
 169 --
 170 report :: IConnection a => Configuration -> a -> IO String
 171 report cfg conn = do
 172   domains <- get_domain_list conn (domain_query cfg)
 173   forwards <- get_forward_list conn (forward_query cfg)
 174
 175   -- valid_forwards are those not excluded based on their address's MXes.
 176   --
 177   -- WARNING: Don't do MX lookups if the exclude list is empty! It
 178   -- wastes a ton of time!
 179   --
 180   -- Don't ask why, but this doesn't work if you factor out the
 181   -- "return" below.
 182   --
 183   let exclude_mx_list = map normalize_string (get_mxs $ exclude_mx cfg)
 184   valid_forwards <- if (null exclude_mx_list)
 185                     then return forwards
 186                     else do
 187                       domain_mxs <- mx_set_map domains
 188                       return $ dropby_mxlist exclude_mx_list domain_mxs forwards
 189
 190   -- We need to normalize our domain names before we can pass them to
 191   -- dropby_goto_domains.
 192   let normal_domains = map normalize_string domains
 193   let remote_forwards = dropby_goto_domains normal_domains valid_forwards
 194   let forward_strings = map pretty_print remote_forwards
 195
 196   -- Don't append the final newline if there's nothing to report.
 197   return $ if (null forward_strings)
 198            then ""
 199            else (join "\n" forward_strings) ++ "\n"
 200
 201
 202
 203 -- * Tests
 204
 205 report_tests :: TestTree
 206 report_tests =
 207   testGroup
 208     "Report Tests"
 209     [ test_example1,
 210       test_dropby_mxlist_affects_address,
 211       test_dropby_mxlist_compares_normalized,
 212       test_dropby_mxlist_requires_subset ]
 213
 214
 215 test_example1 :: TestTree
 216 test_example1 =
 217   testCase desc $ do
 218     conn <- connectSqlite3 "test/fixtures/postfixadmin.sqlite3"
 219     let cfg = def :: Configuration
 220     actual <- report cfg conn
 221     actual @?= expected
 222   where
 223     desc = "all remote forwards are found"
 224     expected = "user1@example.com -> user1@example.net\n" ++
 225                "user2@example.com -> user1@example.org\n" ++
 226                "user2@example.com -> user2@example.org\n" ++
 227                "user2@example.com -> user3@example.org\n" ++
 228                "user7@example.com -> user8@example.net\n"
 229
 230
 231 -- | Make sure we're dropping based on the address and not the goto.
 232 --
 233 test_dropby_mxlist_affects_address :: TestTree
 234 test_dropby_mxlist_affects_address =
 235   testCase desc $ do
 236     let fwds = [fwd "user1@example.com" "user2@example.net"]
 237     let mx_set = Set.fromList [normalize_string "mx.example.net"]
 238     let example_mx_pairs = [(normalize_string "example.net.", mx_set)]
 239     let mx_map = Map.fromList example_mx_pairs
 240     let droplist = ["mx.example.net", "mx2.example.net"]
 241     let normal_droplist = map normalize_string droplist
 242     let actual = dropby_mxlist normal_droplist mx_map fwds
 243     let expected = fwds
 244     actual @?= expected
 245   where
 246     desc = "dropby_mxlist affects the \"address\" and not the \"goto"
 247
 248
 249 -- | Use weird caps, and optional trailing dot all over the place to
 250 --   make sure everything is handled normalized.
 251 --
 252 test_dropby_mxlist_compares_normalized :: TestTree
 253 test_dropby_mxlist_compares_normalized =
 254   testCase desc $ do
 255     let fwds = [fwd "user1@exAmPle.com." "user2@examPle.net"]
 256     let mx_set = Set.fromList [normalize_string "mx.EXAMPLE.com"]
 257     let example_mx_pairs = [(normalize_string "Example.com", mx_set)]
 258     let mx_map = Map.fromList example_mx_pairs
 259     let droplist = ["mx.EXAMple.com", "mx2.example.COM"]
 260     let normal_droplist = map normalize_string droplist
 261     let actual = dropby_mxlist normal_droplist mx_map fwds
 262     let expected = []
 263     actual @?= expected
 264   where
 265     desc = "dropby_mxlist only performs comparisons on normalized names"
 266
 267
 268
 269 -- | Check that if a forward has two MXes, only one of which appears
 270 --   in the list of excluded MXes, it doesn't get dropped.
 271 --
 272 test_dropby_mxlist_requires_subset :: TestTree
 273 test_dropby_mxlist_requires_subset =
 274   testCase desc $ do
 275     let fwds = [fwd "user1@example.com" "user2@example.net"]
 276     let mx_set = Set.fromList ["mx1.example.com", "mx2.example.com"]
 277     let normal_mx_set = Set.map normalize_string mx_set
 278     let example_mx_pairs = [(normalize_string "example.com.", normal_mx_set)]
 279     let mx_map = Map.fromList example_mx_pairs
 280     let droplist = ["mx1.example.com"]
 281     let normal_droplist = map normalize_string droplist
 282     let actual = dropby_mxlist normal_droplist mx_map fwds
 283     let expected = fwds
 284     actual @?= expected
 285   where
 286     desc = "dropby_mxlist requires all mx to be in the exclude list"