src/Report.hs

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