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