{-# LANGUAGE PatternGuards #-} module Report ( report, report_tests ) where import Control.Monad ( filterM ) import qualified Data.ByteString.Char8 as BS ( pack ) import Data.Maybe ( catMaybes, listToMaybe ) import Data.String.Utils ( join, split, strip ) import Database.HDBC ( IConnection, execute, prepare, sFetchAllRows') import Database.HDBC.Sqlite3 ( connectSqlite3 ) import Data.List ( (\\) ) import Network.DNS.Utils ( normalize ) import System.Console.CmdArgs.Default ( Default(..) ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Configuration ( Configuration(..) ) import DNS ( lookup_mxs ) import MxList ( MxList(..) ) -- Type synonyms to make the signatures below a little more clear. type Domain = String type Address = String type Goto = String -- | A data type representing a "forward." That is, an email address -- whose mail is sent to some other address. -- -- The 'Address' field represents the alias address, the address to -- which mail is sent. The 'Goto' field is the address to which the -- mail is forwarded. -- data Forward = Forward Address Goto deriving (Show) -- | 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 -- 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! _ <- execute stmt [] -- rows :: [[Maybe String]] rows <- sFetchAllRows' stmt -- rows' :: [Maybe String] let rows' = map (listToMaybe . catMaybes) rows -- domains :: [String] let domains = catMaybes rows' return domains -- | Convert a row obtained in 'get_forward_list' into a list of -- 'Forward's. The row is assumed to have two columns, the first -- with an address, and the second with a comma-separated list of -- gotos. -- -- We return a list containing one entry for each address, goto pair. -- -- ==== __Examples__ -- -- A single address, pointed to itself (common with PostfixAdmin): -- -- >>> let addr = "a@b.test" -- >>> let gotos = "a@b.test" -- >>> row_to_forwards [addr, gotos] -- [Forward "a@b.test" "a@b.test"] -- -- One address forwarded to two other addresses: -- -- >>> let addr = "a@b.test" -- >>> let gotos = "a1@b.test,a2@b.test" -- >>> row_to_forwards [addr, gotos] -- [Forward "a@b.test" "a1@b.test",Forward "a@b.test" "a2@b.test"] -- -- An address that receives mail itself, but also forwards a copy to -- another address (also common in PostfixAdmin). We've also mangled -- the whitespace a little bit here: -- -- >>> let addr = "a@b.test" -- >>> let gotos = "a@b.test ,a2@b.test " -- >>> row_to_forwards [addr, gotos] -- [Forward "a@b.test" "a@b.test",Forward "a@b.test" "a2@b.test"] -- -- And finally, a one-element list, which should return no forwards: -- -- >>> let addr = "a@b.test" -- >>> row_to_forwards [addr] -- [] -- row_to_forwards :: [String] -> [Forward] row_to_forwards (addr:gotos:_) = [Forward addr (strip g) | g <- split "," gotos] row_to_forwards _ = [] -- | 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 -- 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! _ <- execute stmt [] -- rows :: [[Maybe String]] rows <- sFetchAllRows' stmt -- forwards :: [Forward] let forwards = concatMap (row_to_forwards . catMaybes) rows return forwards -- | Given a list of local 'Domain's and a list of 'Forward's, filter -- out all of the local forwards and return only the remaining -- (remote) forwards. -- -- ==== __Examples__ -- -- >>> let ds = ["example.com", "example.net"] -- >>> let f1 = Forward "a@example.com" "a@example.com" -- >>> let f2 = Forward "a@example.com" "a1@example.net" -- >>> let f3 = Forward "a@example.com" "a2@example.org" -- >>> find_remote_forwards ds [f1,f2,f3] -- [Forward "a@example.com" "a2@example.org"] -- find_remote_forwards :: [Domain] -> [Forward] -> [Forward] find_remote_forwards domains forwards = filter is_remote forwards where is_remote :: Forward -> Bool is_remote (Forward _ goto) = let parts = split "@" goto in case parts of (_:dp:[]) -> not $ dp `elem` domains _ -> True -- Assume it's remote if something is wrong -- | Format a 'Forward' for pretty printing. -- -- ==== __Examples__ -- -- >>> let fwd = Forward "a@example.com" "b@example.net" -- >>> format_forward fwd -- "a@example.com -> b@example.net" -- format_forward :: Forward -> String format_forward (Forward addr goto) = addr ++ " -> " ++ goto -- | A filter function to remove specific 'Forward's from a list (of -- fowards). Its intended usage is to ignore a 'Forward' if its -- 'Address' has an MX record 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 exactly those contained in the -- 'MxList', then we exclude that domain from the report. Splitting on -- the '@' is a lazy way of obtaining the domain, but if it's good -- enough for determining that a forward is remote, then it's good -- enough for this. -- -- 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. -- filter_by_mx :: MxList -> [Forward] -> IO [Forward] filter_by_mx (MxList []) = return filter_by_mx (MxList mxs) = filterM all_mxs_excluded where all_mxs_excluded :: Forward -> IO Bool all_mxs_excluded (Forward addr _) = case (split "@" addr) of (_:domain_part:[]) -> do fw_mxs <- lookup_mxs (BS.pack domain_part) let norm_mxs = map (normalize . BS.pack) mxs if (norm_mxs \\ fw_mxs) == [] then return False else return True _ -> return True -- Report it if we can't figure out the domain. -- | 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 <- filter_by_mx (exclude_mx cfg) forwards let remote_forwards = find_remote_forwards domains valid_forwards let forward_strings = map format_forward remote_forwards return $ (join "\n" forward_strings) -- * Tests report_tests :: TestTree report_tests = testGroup "Report Tests" [ test_example1 ] 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"