src/Report.hs

   1 {-# LANGUAGE PatternGuards #-}
   2
   3 module Report (
   4   report,
   5   report_tests )
   6 where
   7
   8 import Data.Map ( mapKeys )
   9 import qualified Data.Map as Map ( lookup )
  10 import Data.Maybe ( catMaybes, listToMaybe )
  11 import Data.Set ( fromList, isSubsetOf )
  12 import qualified Data.Set as Set ( map )
  13 import Data.String.Utils ( join )
  14 import Database.HDBC (
  15   IConnection,
  16   execute,
  17   prepare,
  18   sFetchAllRows')
  19 import Database.HDBC.Sqlite3 ( connectSqlite3 )
  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 ( MxSetMap, mx_set_map, normalize_string_domain )
  26 import Forward (
  27   Forward(..),
  28   address_domain,
  29   dropby_goto_domains,
  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 -- | Given a connection @conn@ and a @query@, return a list of domains
  39 --   found by executing @query@ on @conn. The @query@ is assumed to
  40 --   return only one column, containing domains.
  41 --
  42 get_domain_list :: IConnection a
  43                 => a -- ^ A database connection
  44                 -> String -- ^ The @query@ to execute
  45                 -> IO [Domain] -- ^ The list of domains returned from @query@
  46 get_domain_list conn query = do
  47   stmt <- prepare conn query
  48
  49   -- We really want executeRaw here, but there's a bug: it will tell
  50   -- us we can't fetch rows from the statement since it hasn't been
  51   -- executed yet!
  52   _ <- execute stmt []
  53
  54   -- rows :: [[Maybe String]]
  55   rows <- sFetchAllRows' stmt
  56
  57   -- rows' :: [Maybe String]
  58   let rows' = map (listToMaybe . catMaybes) rows
  59
  60   -- domains :: [String]
  61   let domains = catMaybes rows'
  62
  63   return domains
  64
  65
  66
  67
  68 -- | Given a connection @conn@ and a @query@, return a list of
  69 --   forwards found by executing @query@ on @conn. The @query@ is
  70 --   assumed to return two columns, the first containing addresses and
  71 --   the second containing a comma-separated list of gotos (as a
  72 --   string).
  73 --
  74 get_forward_list :: IConnection a
  75                  => a  -- ^ A database connection
  76                  -> String -- ^ The @query@ to execute
  77                  -> IO [Forward]  -- ^ A list of forwards returned from @query@
  78 get_forward_list conn query = do
  79   stmt <- prepare conn query
  80
  81   -- We really want executeRaw here, but there's a bug: it will tell
  82   -- us we can't fetch rows from the statement since it hasn't been
  83   -- executed yet!
  84   _ <- execute stmt []
  85
  86   -- rows :: [[Maybe String]]
  87   rows <- sFetchAllRows' 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 qualified Data.Map as Map ( fromList )
 129 --   >>> import qualified Data.Set as Set ( fromList )
 130 --   >>> import Forward ( fwd )
 131 --   >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
 132 --   >>> let mx_set = Set.fromList ["mx.example.com"]
 133 --   >>> let example_mx_pairs = [("example.com.", mx_set)]
 134 --   >>> let mx_map = Map.fromList example_mx_pairs
 135 --   >>> let droplist = MxList ["mx.example.com", "mx2.example.com"]
 136 --   >>> map pretty_print (dropby_mxlist droplist mx_map fwds)
 137 --   []
 138 --
 139 --   Repeat the previous test with the goto domain, to make sure we're
 140 --   dropping based on the address and not the goto:
 141 --
 142 --   >>> import qualified Data.Map as Map ( fromList )
 143 --   >>> import qualified Data.Set as Set ( fromList )
 144 --   >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
 145 --   >>> let mx_set = Set.fromList ["mx.example.net"]
 146 --   >>> let example_mx_pairs = [("example.net.", mx_set)]
 147 --   >>> let mx_map = Map.fromList example_mx_pairs
 148 --   >>> let droplist = MxList ["mx.example.net", "mx2.example.net"]
 149 --   >>> map pretty_print (dropby_mxlist droplist mx_map fwds)
 150 --   ["user1@example.com -> user2@example.net"]
 151 --
 152 --   Use weird caps, and optional trailing dot all over the place to
 153 --   make sure everything is handled normalized:
 154 --
 155 --   >>> import qualified Data.Set as Set ( fromList )
 156 --   >>> import Forward ( fwd )
 157 --   >>> let fwds = [fwd "user1@exAmPle.com." "user2@examPle.net"]
 158 --   >>> let mx_set = Set.fromList ["mx.EXAMPLE.com"]
 159 --   >>> let example_mx_pairs = [("Example.com", mx_set)]
 160 --   >>> let mx_map = Map.fromList example_mx_pairs
 161 --   >>> let droplist = MxList ["mx.EXAMple.com", "mx2.example.COM"]
 162 --   >>> map pretty_print (dropby_mxlist droplist mx_map fwds)
 163 --   []
 164 --
 165 --   This time it shouldn't be dropped, because ["mx.example.com"] is
 166 --   not contained in ["nope.example.com"]:
 167 --
 168 --   >>> import qualified Data.Map as Map ( fromList )
 169 --   >>> import qualified Data.Set as Set ( fromList )
 170 --   >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
 171 --   >>> let mx_set = Set.fromList ["mx.example.com"]
 172 --   >>> let example_mx_pairs = [("example.com.", mx_set)]
 173 --   >>> let mx_map = Map.fromList example_mx_pairs
 174 --   >>> let droplist = MxList ["nope.example.com"]
 175 --   >>> map pretty_print (dropby_mxlist droplist mx_map fwds)
 176 --   ["user1@example.com -> user2@example.net"]
 177 --
 178 --   Now we check that if a forward has two MXes, one of which appears
 179 --   in the list of excluded MXes, it doesn't get dropped:
 180 --
 181 --   >>> import qualified Data.Map as Map ( fromList )
 182 --   >>> import qualified Data.Set as Set ( fromList )
 183 --   >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
 184 --   >>> let mx_set = Set.fromList ["mx1.example.com", "mx2.example.com"]
 185 --   >>> let example_mx_pairs = [("example.com.", mx_set)]
 186 --   >>> let mx_map = Map.fromList example_mx_pairs
 187 --   >>> let droplist = MxList ["mx1.example.com"]
 188 --   >>> map pretty_print (dropby_mxlist droplist mx_map fwds)
 189 --   ["user1@example.com -> user2@example.net"]
 190 --
 191 dropby_mxlist :: MxList -> MxSetMap -> [Forward] -> [Forward]
 192 dropby_mxlist (MxList []) _ = id
 193 dropby_mxlist (MxList mxs) domain_mx_map =
 194   filter (not . is_bad)
 195   where
 196     -- If we don't normalize these first, comparison (isSubsetOf)
 197     -- doesn't work so great.
 198     mx_set = fromList (map normalize_string_domain mxs)
 199
 200     -- We perform a lookup using a normalized key, so we'd better
 201     -- normalize the keys in the map first!
 202     normal_mxmap = mapKeys normalize_string_domain domain_mx_map
 203
 204     is_bad :: Forward -> Bool
 205     is_bad f =
 206       case (address_domain f) of
 207         Nothing -> False -- Do **NOT** drop these.
 208         Just d  -> case (Map.lookup (normalize_string_domain d) normal_mxmap) of
 209                      Nothing -> False -- No domain MX? Don't drop.
 210
 211                      -- We need to normalize the set of MXes for the
 212                      -- domain, too.
 213                      Just dmxs ->
 214                        let ndmxs = (Set.map normalize_string_domain dmxs)
 215                        in
 216                          ndmxs `isSubsetOf` mx_set
 217
 218
 219 -- | Given a connection and a 'Configuration', produces the report as
 220 --   a 'String'.
 221 --
 222 report :: IConnection a => Configuration -> a -> IO String
 223 report cfg conn = do
 224   domains <- get_domain_list conn (domain_query cfg)
 225   forwards <- get_forward_list conn (forward_query cfg)
 226
 227   -- valid_forwards are those not excluded based on their address's MXes.
 228   --
 229   -- WARNING: Don't do MX lookups if the exclude list is empty! It
 230   -- wastes a ton of time!
 231   --
 232   -- Don't ask why, but this doesn't work if you factor out the
 233   -- "return" below.
 234   --
 235   let exclude_mx_list = exclude_mx cfg
 236   valid_forwards <- if null (get_mxs exclude_mx_list)
 237                     then return forwards
 238                     else do
 239                       domain_mxs <- mx_set_map domains
 240                       return $ dropby_mxlist exclude_mx_list domain_mxs forwards
 241
 242   let remote_forwards = dropby_goto_domains domains valid_forwards
 243   let forward_strings = map pretty_print remote_forwards
 244
 245   -- Don't append the final newline if there's nothing to report.
 246   return $ if (null forward_strings)
 247            then ""
 248            else (join "\n" forward_strings) ++ "\n"
 249
 250
 251
 252 -- * Tests
 253
 254 report_tests :: TestTree
 255 report_tests =
 256   testGroup "Report Tests" [ test_example1 ]
 257
 258
 259 test_example1 :: TestTree
 260 test_example1 =
 261   testCase desc $ do
 262     conn <- connectSqlite3 "test/fixtures/postfixadmin.sqlite3"
 263     let cfg = def :: Configuration
 264     actual <- report cfg conn
 265     actual @?= expected
 266   where
 267     desc = "all remote forwards are found"
 268     expected = "user1@example.com -> user1@example.net\n" ++
 269                "user2@example.com -> user1@example.org\n" ++
 270                "user2@example.com -> user2@example.org\n" ++
 271                "user2@example.com -> user3@example.org\n" ++
 272                "user7@example.com -> user8@example.net\n"