module Report (
  report,
  report_tests )
where

import qualified Data.Map as Map ( fromList, lookup )
import Data.Maybe ( catMaybes, listToMaybe )
import Data.Set ( isSubsetOf )
import qualified Data.Set as Set ( fromList, map )
import Data.String.Utils ( join )
import Database.HDBC (
  IConnection,
  Statement,
  execute,
  prepare,
  sFetchAllRows')
import Database.HDBC.Sqlite3 ( connectSqlite3 )
import System.Console.CmdArgs.Default ( Default( def ) )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )

import Configuration ( Configuration( domain_query,
                                      exclude_mx,
                                      forward_query) )
import DNS (
  MxSetMap,
  NormalDomain,
  mx_set_map,
  normalize_string )
import Forward (
  Forward(),
  address_domain,
  dropby_goto_domains,
  fwd,
  pretty_print,
  strings_to_forwards )
import MxList ( MxList( get_mxs ) )

-- | Type synonym to make the signatures below a little more clear.
--   WARNING: Also defined in the "Forward" module.
type Domain = String


-- | We really want executeRaw here, but there's a bug: it will tell
--   us we can't fetch rows from the statement since it hasn't been
--   executed yet!
--
my_executeRaw :: Statement -> IO [[Maybe String]]
my_executeRaw stmt = do
  _ <- execute stmt []
  sFetchAllRows' stmt


-- | Given a connection @conn@ and a @query@, return a list of domains
--   found by executing @query@ on @conn. The @query@ is assumed to
--   return only one column, containing domains.
--
get_domain_list :: IConnection a
                => a -- ^ A database connection
                -> String -- ^ The @query@ to execute
                -> IO [Domain] -- ^ The list of domains returned from @query@
get_domain_list conn query = do
  stmt <- prepare conn query
  rows <- my_executeRaw stmt

  -- rows' :: [Maybe String]
  let rows' = map (listToMaybe . catMaybes) rows

  -- domains :: [String]
  let domains = catMaybes rows'

  return domains




-- | Given a connection @conn@ and a @query@, return a list of
--   forwards found by executing @query@ on @conn. The @query@ is
--   assumed to return two columns, the first containing addresses and
--   the second containing a comma-separated list of gotos (as a
--   string).
--
get_forward_list :: IConnection a
                 => a  -- ^ A database connection
                 -> String -- ^ The @query@ to execute
                 -> IO [Forward]  -- ^ A list of forwards returned from @query@
get_forward_list conn query = do
  stmt <- prepare conn query
  rows <- my_executeRaw stmt

  -- forwards :: [Forward]
  let forwards = concatMap (strings_to_forwards . catMaybes) rows

  return forwards



-- | A filter function to remove specific 'Forward's from a list (of
--   forwards).  Its intended usage is to ignore a 'Forward' if its
--   'Address' has MX records that are all contained in the given
--   list. This could be useful if, for example, one MX has strict
--   spam filtering and remote forwards are not a problem for domains
--   with that MX.
--
--   If the MX records for a domain are contained in the 'MxList',
--   then we exclude that domain from the report.
--
--   For performance reasons, we want to have precomputed the MX
--   records for all of the address domains in our list of
--   forwards. We do this so we don't look up the MX records twice for
--   two addresses within the same domain. We could just as well do
--   this within this function, but by taking the @domain_mxs@ as a
--   parameter, we allow ourselves to be a pure function.
--
--   If the domain of a forward address can't be determined, it won't
--   be dropped! This is intentional: the existence of a forward
--   address without a domain part probably indicates a configuration
--   error somewhere, and we should report it.
--
--   The empty @MxList []@ special case is necessary! Otherwise if we
--   have an empty exclude list and a domain that has no MX record, it
--   will be excluded.
--
--   ==== __Examples__
--
--   Our single forward should be dropped from the list, because its
--   MX record list, ["mx.example.com"], is contained in the list of
--   excluded MXs:
--
--   >>> import Forward ( fwd )
--   >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
--   >>> let mx_set = Set.fromList [normalize_string "mx.example.com"]
--   >>> let example_mx_pairs = [(normalize_string "example.com.", mx_set)]
--   >>> let mx_map = Map.fromList example_mx_pairs
--   >>> let droplist = ["mx.example.com", "mx2.example.com"]
--   >>> let normal_droplist = map normalize_string droplist
--   >>> dropby_mxlist normal_droplist mx_map fwds
--   []
--
--   This time it shouldn't be dropped, because ["mx.example.com"] is
--   not contained in ["nope.example.com"]:
--
--   >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
--   >>> let mx_set = Set.fromList [normalize_string "mx.example.com"]
--   >>> let example_mx_pairs = [(normalize_string "example.com.", mx_set)]
--   >>> let mx_map = Map.fromList example_mx_pairs
--   >>> let droplist = ["nope.example.com"]
--   >>> let normal_droplist = map normalize_string droplist
--   >>> map pretty_print (dropby_mxlist normal_droplist mx_map fwds)
--   ["user1@example.com -> user2@example.net"]
--
dropby_mxlist :: [NormalDomain] -> MxSetMap -> [Forward] -> [Forward]
dropby_mxlist [] _ = id
dropby_mxlist normal_mxs mx_map =
  filter (not . is_bad)
  where
    mx_set = Set.fromList normal_mxs

    is_bad :: Forward -> Bool
    is_bad f =
      case (address_domain f) of
        Nothing -> False -- Do **NOT** drop these.
        Just d  -> case (Map.lookup (normalize_string d) mx_map) of
                     Nothing -> False -- No domain MX? Don't drop.
                     Just dmxs -> dmxs `isSubsetOf` mx_set



-- | Given a connection and a 'Configuration', produces the report as
--   a 'String'.
--
report :: IConnection a => Configuration -> a -> IO String
report cfg conn = do
  domains <- get_domain_list conn (domain_query cfg)
  forwards <- get_forward_list conn (forward_query cfg)

  -- valid_forwards are those not excluded based on their address's MXes.
  --
  -- WARNING: Don't do MX lookups if the exclude list is empty! It
  -- wastes a ton of time!
  --
  -- Don't ask why, but this doesn't work if you factor out the
  -- "return" below.
  --
  let exclude_mx_list = map normalize_string (get_mxs $ exclude_mx cfg)
  valid_forwards <- if (null exclude_mx_list)
                    then return forwards
                    else do
                      domain_mxs <- mx_set_map domains
                      return $ dropby_mxlist exclude_mx_list domain_mxs forwards

  -- We need to normalize our domain names before we can pass them to
  -- dropby_goto_domains.
  let normal_domains = map normalize_string domains
  let remote_forwards = dropby_goto_domains normal_domains valid_forwards
  let forward_strings = map pretty_print remote_forwards

  -- Don't append the final newline if there's nothing to report.
  return $ if (null forward_strings)
           then ""
           else (join "\n" forward_strings) ++ "\n"



-- * Tests

report_tests :: TestTree
report_tests =
  testGroup
    "Report Tests"
    [ test_example1,
      test_dropby_mxlist_affects_address,
      test_dropby_mxlist_compares_normalized,
      test_dropby_mxlist_requires_subset ]


test_example1 :: TestTree
test_example1 =
  testCase desc $ do
    conn <- connectSqlite3 "test/fixtures/postfixadmin.sqlite3"
    let cfg = def :: Configuration
    actual <- report cfg conn
    actual @?= expected
  where
    desc = "all remote forwards are found"
    expected = "user1@example.com -> user1@example.net\n" ++
               "user2@example.com -> user1@example.org\n" ++
               "user2@example.com -> user2@example.org\n" ++
               "user2@example.com -> user3@example.org\n" ++
               "user7@example.com -> user8@example.net\n"


-- | Make sure we're dropping based on the address and not the goto.
--
test_dropby_mxlist_affects_address :: TestTree
test_dropby_mxlist_affects_address =
  testCase desc $ do
    let fwds = [fwd "user1@example.com" "user2@example.net"]
    let mx_set = Set.fromList [normalize_string "mx.example.net"]
    let example_mx_pairs = [(normalize_string "example.net.", mx_set)]
    let mx_map = Map.fromList example_mx_pairs
    let droplist = ["mx.example.net", "mx2.example.net"]
    let normal_droplist = map normalize_string droplist
    let actual = dropby_mxlist normal_droplist mx_map fwds
    let expected = fwds
    actual @?= expected
  where
    desc = "dropby_mxlist affects the \"address\" and not the \"goto"


-- | Use weird caps, and optional trailing dot all over the place to
--   make sure everything is handled normalized.
--
test_dropby_mxlist_compares_normalized :: TestTree
test_dropby_mxlist_compares_normalized =
  testCase desc $ do
    let fwds = [fwd "user1@exAmPle.com." "user2@examPle.net"]
    let mx_set = Set.fromList [normalize_string "mx.EXAMPLE.com"]
    let example_mx_pairs = [(normalize_string "Example.com", mx_set)]
    let mx_map = Map.fromList example_mx_pairs
    let droplist = ["mx.EXAMple.com", "mx2.example.COM"]
    let normal_droplist = map normalize_string droplist
    let actual = dropby_mxlist normal_droplist mx_map fwds
    let expected = [] :: [Forward]
    actual @?= expected
  where
    desc = "dropby_mxlist only performs comparisons on normalized names"



-- | Check that if a forward has two MXes, only one of which appears
--   in the list of excluded MXes, it doesn't get dropped.
--
test_dropby_mxlist_requires_subset :: TestTree
test_dropby_mxlist_requires_subset =
  testCase desc $ do
    let fwds = [fwd "user1@example.com" "user2@example.net"]
    let mx_set = Set.fromList ["mx1.example.com", "mx2.example.com"]
    let normal_mx_set = Set.map normalize_string mx_set
    let example_mx_pairs = [(normalize_string "example.com.", normal_mx_set)]
    let mx_map = Map.fromList example_mx_pairs
    let droplist = ["mx1.example.com"]
    let normal_droplist = map normalize_string droplist
    let actual = dropby_mxlist normal_droplist mx_map fwds
    let expected = fwds
    actual @?= expected
  where
    desc = "dropby_mxlist requires all mx to be in the exclude list"
