-module DNS ( lookup_mxs )
+module DNS (
+ MxSetMap,
+ mx_set_map,
+ normalize_string_domain )
where
+import qualified Data.ByteString.Char8 as BS ( pack, unpack )
+import Data.List ( nub )
+import Data.Map ( Map )
+import qualified Data.Map as Map ( fromList )
+import Data.Set ( Set )
+import qualified Data.Set as Set ( fromList )
import Network.DNS (
Domain,
defaultResolvConf,
lookupMX,
makeResolvSeed,
+ normalize,
withResolver )
+-- | A map from domain names (represented as 'String's) to sets of
+-- mail exchanger names (also represented as 'String's).
+--
+type MxSetMap = Map String MxSet
+
+-- | A set of mail exchanger names, represented as 'String's.
+type MxSet = Set String
+
+
+-- | Normalize a domain name string by converting to a 'Domain',
+-- calling 'normalize', and then converting back.
+--
+-- ==== __Examples__
+--
+-- >>> normalize_string_domain "ExAMplE.com"
+-- "example.com."
+--
+normalize_string_domain :: String -> String
+normalize_string_domain = BS.unpack . normalize . BS.pack
+
-- | Retrieve all MX records for the given domain. This is somewhat
-- inefficient, since we create the resolver every time.
return $ case mxs of
Left _ -> []
Right pairs -> map fst pairs
+
+
+-- | Takes a list of domain names represented as 'String's and
+-- constructs a map from domain names to sets of mail exchangers
+-- (for those domain names) also represented as 'String's.
+--
+-- During construction, we have to switch to the DNS internal
+-- representation of a 'Domain' which uses ByteStrings, but before
+-- we return the map to the client, we want everything to be in
+-- terms of standard 'String's for comparison purposes.
+--
+-- The list of domains is normalized and de-duped before lookups are
+-- performed to avoid doing lookups twice for identical domains.
+--
+mx_set_map :: [String] -> IO MxSetMap
+mx_set_map domains = do
+ -- Construct a list of pairs.
+ pairs <- mapM make_pair unique_domains
+
+ -- And make a map from the pairs.
+ return $ Map.fromList pairs
+
+ where
+ -- Convert, normalize, and de-dupe the @domains@.
+ unique_domains :: [Domain]
+ unique_domains = nub $ map (normalize . BS.pack) domains
+
+ -- | Convert a string domain name into a pair containing the
+ -- domain name in the first component and a set of its mail
+ -- exchangers (as strings) in the second component.
+ --
+ make_pair :: Domain -> IO (String, Set String)
+ make_pair domain = do
+ -- Lookup the @domain@'s MX records.
+ mx_list <- lookup_mxs domain
+
+ -- Now convert the MX records *back* to strings.
+ let string_mx_list = map BS.unpack mx_list
+
+ -- Convert the list into a set
+ let string_mx_set = Set.fromList string_mx_list
+
+ -- Finally, construct the pair and return it.
+ return (BS.unpack domain, string_mx_set)
--- /dev/null
+-- | The 'Forward' data type, and functions that act thereon.
+--
+module Forward (
+ Forward(..),
+ address_domain,
+ dropby_goto_domains,
+ fwd,
+ pretty_print,
+ strings_to_forwards )
+where
+
+import Data.String.Utils ( split, strip )
+
+import DNS ( normalize_string_domain )
+
+-- | Type synonym to make the signatures below a little more clear.
+-- WARNING: Also defined in the "Report" module.
+type Domain = String
+
+
+-- | A type-safe wrapper around an email address that's represented as
+-- a 'String'. This differs from a 'Goto' in that it should only
+-- appear on the left-hand-side of a alias -> goto relationship.
+--
+newtype Address = Address String deriving ( Show )
+
+
+-- | A type-safe wrapper around an email address that's represented as
+-- a 'String'. This differs from 'Address' in that 'Goto' addresses
+-- are the destinations of mail that is forwarded, rather than the
+-- source.
+newtype Goto = Goto String deriving ( Show )
+
+
+-- | 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)
+
+
+-- | Shortcut constructor for creating 'Forward' objects.
+--
+-- ==== __Examples__
+--
+-- >>> pretty_print $ fwd "user1@example.com" "user2@example.net"
+-- "user1@example.com -> user2@example.net"
+--
+fwd :: String -> String -> Forward
+fwd addr goto = Forward (Address addr) (Goto goto)
+
+
+-- | Pretty-print a 'Forward'.
+--
+-- ==== __Examples__
+--
+-- >>> pretty_print (fwd "a@example.com" "b@example.net")
+-- "a@example.com -> b@example.net"
+--
+pretty_print :: Forward -> String
+pretty_print ( Forward (Address addr) (Goto goto) ) =
+ addr ++ " -> " ++ goto
+
+
+
+-- | Convert a list of 'String's into a list of 'Forward's. The list
+-- of 'String's is assumed to have exactly two elements; the first
+-- being an address, and the second being a comma-separated list of
+-- gotos.
+--
+-- We return a list containing one 'Forward' 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"
+-- >>> strings_to_forwards [addr, gotos]
+-- [Forward (Address "a@b.test") (Goto "a@b.test")]
+--
+-- One address forwarded to two other addresses:
+--
+-- >>> let addr = "a@b.test"
+-- >>> let gotos = "a1@b.test,a2@b.test"
+-- >>> map pretty_print (strings_to_forwards [addr, gotos])
+-- ["a@b.test -> a1@b.test","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 "
+-- >>> map pretty_print (strings_to_forwards [addr, gotos])
+-- ["a@b.test -> a@b.test","a@b.test -> a2@b.test"]
+--
+-- And finally, a one-element list, which should return no forwards:
+--
+-- >>> let addr = "a@b.test"
+-- >>> strings_to_forwards [addr]
+-- []
+--
+strings_to_forwards :: [String] -> [Forward]
+strings_to_forwards (addr:gotos:_) =
+ [Forward (Address addr) (Goto (strip g)) | g <- split "," gotos]
+strings_to_forwards _ = []
+
+
+-- | Find the domain of the 'Goto' associated with a 'Forward'. This
+-- returns the __domain of the goto address__, not the domain of the
+-- 'Address' itself.
+--
+-- ==== __Examples__
+--
+-- A normal forward:
+--
+-- >>> let f = fwd "user1@example.com" "user2@example.net"
+-- >>> goto_domain f
+-- Just "example.net"
+--
+-- A forward to a subdomain:
+--
+-- >>> let f = fwd "user1@example.com" "user2@sub.example.net"
+-- >>> goto_domain f
+-- Just "sub.example.net"
+--
+-- A goto without an '@' character:
+--
+-- >>> let f = fwd "user1@example.com" "example.net"
+-- >>> goto_domain f
+-- Nothing
+--
+-- A goto with three '@' characters:
+--
+-- >>> let f = fwd "user1@example.com" "@example@.net@"
+-- >>> goto_domain f
+-- Nothing
+--
+goto_domain :: Forward -> Maybe Domain
+goto_domain (Forward _ (Goto goto)) = domain_part goto
+
+
+-- | Find the domain of the 'Address' associated with a 'Forward'. This
+-- returns the __domain of the address__, not the domain of the
+-- 'Goto'.
+--
+-- ==== __Examples__
+--
+-- A normal forward:
+--
+-- >>> let f = fwd "user1@example.com" "user2@example.net"
+-- >>> address_domain f
+-- Just "example.com"
+--
+-- A forward to/from subdomains:
+--
+-- >>> let f = fwd "user1@sub.example.com" "user2@sub.example.net"
+-- >>> address_domain f
+-- Just "sub.example.com"
+--
+-- An address/goto without an '@' character:
+--
+-- >>> let f = fwd "example.com" "example.net"
+-- >>> address_domain f
+-- Nothing
+--
+-- An address/goto with three '@' characters:
+--
+-- >>> let f = fwd "@example@.com@" "@example@.net@"
+-- >>> address_domain f
+-- Nothing
+--
+address_domain :: Forward -> Maybe Domain
+address_domain (Forward (Address addr) _) = domain_part addr
+
+
+-- | Return the domain part of an email address (represented by a
+-- 'String').
+--
+-- The way we determine the domain is simple: we take whatever
+-- appears after the first '@' character in the address. If there is
+-- no '@' symbol, or if there's more than one, then we don't know
+-- what the domain is, so we return 'Nothing' instead.
+--
+-- ==== __Examples__
+--
+-- A normal address:
+--
+-- >>> domain_part "user2@example.net"
+-- Just "example.net"
+--
+-- A subdomain:
+--
+-- >>> domain_part "user2@sub.example.net"
+-- Just "sub.example.net"
+--
+-- An address without an '@' character:
+--
+-- >>> domain_part "example.net"
+-- Nothing
+--
+-- An address with two '@' characters:
+--
+-- >>> domain_part "@example@.net@"
+-- Nothing
+--
+domain_part :: String -> Maybe Domain
+domain_part address =
+ case parts of
+ (_:domain:[]) -> Just domain
+ _ -> Nothing
+ where
+ parts = split "@" address
+
+
+-- | Given a list of 'Domain's @domains@ and a list of 'Forward's
+-- @forwards@, filter out all elements of @forwards@ that have a
+-- goto domain in the list of @domains@.
+--
+-- ==== __Examples__
+--
+-- >>> let ds = ["example.com", "example.net"]
+-- >>> let f1 = fwd "a@example.com" "a@example.com"
+-- >>> let f2 = fwd "a@example.com" "a1@example.net"
+-- >>> let f3 = fwd "a@example.com" "a2@example.org"
+-- >>> map pretty_print (dropby_goto_domains ds [f1,f2,f3])
+-- ["a@example.com -> a2@example.org"]
+--
+dropby_goto_domains :: [Domain] -> [Forward] -> [Forward]
+dropby_goto_domains domains =
+ filter (not . is_bad)
+ where
+ -- If we don't normalize these first, comparison (i.e. `elem`)
+ -- doesn't work so great.
+ normalized_domains = map normalize_string_domain domains
+
+ -- | A 'Forward' is bad if its goto domain appears in the list, or
+ -- if we can't figure out its goto domain.
+ --
+ is_bad :: Forward -> Bool
+ is_bad f =
+ case (goto_domain f) of
+ Nothing -> True -- Drop these, too.
+ Just d -> (normalize_string_domain d) `elem` normalized_domains
report_tests )
where
-import Control.Monad ( filterM )
-import qualified Data.ByteString.Char8 as BS ( pack )
+import Data.Map ( mapKeys )
+import qualified Data.Map as Map ( lookup )
import Data.Maybe ( catMaybes, listToMaybe )
-import Data.String.Utils ( join, split, strip )
+import Data.Set ( fromList, isSubsetOf )
+import qualified Data.Set as Set ( map )
+import Data.String.Utils ( join )
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 DNS ( MxSetMap, mx_set_map, normalize_string_domain )
+import Forward (
+ Forward(..),
+ address_domain,
+ dropby_goto_domains,
+ pretty_print,
+ strings_to_forwards )
import MxList ( MxList(..) )
--- Type synonyms to make the signatures below a little more clear.
+-- | Type synonym to make the signatures below a little more clear.
+-- WARNING: Also defined in the "Forward" module.
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 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
rows <- sFetchAllRows' stmt
-- forwards :: [Forward]
- let forwards = concatMap (row_to_forwards . catMaybes) rows
+ let forwards = concatMap (strings_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.
+-- | 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.
--
--- ==== __Examples__
+-- If the MX records for a domain are contained in the 'MxList',
+-- then we exclude that domain from the report.
--
--- >>> 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"]
+-- 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.
--
-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.
+-- 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__
--
--- >>> let fwd = Forward "a@example.com" "b@example.net"
--- >>> format_forward fwd
--- "a@example.com -> b@example.net"
+-- 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:
--
-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.
+-- >>> import qualified Data.Map as Map ( fromList )
+-- >>> import qualified Data.Set as Set ( fromList )
+-- >>> import Forward ( fwd )
+-- >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
+-- >>> let mx_set = Set.fromList ["mx.example.com"]
+-- >>> let example_mx_pairs = [("example.com.", mx_set)]
+-- >>> let mx_map = Map.fromList example_mx_pairs
+-- >>> let droplist = MxList ["mx.example.com", "mx2.example.com"]
+-- >>> map pretty_print (dropby_mxlist droplist mx_map fwds)
+-- []
--
--- 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.
+-- Repeat the previous test with the goto domain, to make sure we're
+-- dropping based on the address and not the goto:
--
--- 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.
+-- >>> import qualified Data.Map as Map ( fromList )
+-- >>> import qualified Data.Set as Set ( fromList )
+-- >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
+-- >>> let mx_set = Set.fromList ["mx.example.net"]
+-- >>> let example_mx_pairs = [("example.net.", mx_set)]
+-- >>> let mx_map = Map.fromList example_mx_pairs
+-- >>> let droplist = MxList ["mx.example.net", "mx2.example.net"]
+-- >>> map pretty_print (dropby_mxlist droplist mx_map fwds)
+-- ["user1@example.com -> user2@example.net"]
--
-filter_by_mx :: MxList -> [Forward] -> IO [Forward]
-filter_by_mx (MxList []) = return
-filter_by_mx (MxList mxs) =
- filterM all_mxs_excluded
+-- Use weird caps, and optional trailing dot all over the place to
+-- make sure everything is handled normalized:
+--
+-- >>> import qualified Data.Set as Set ( fromList )
+-- >>> import Forward ( fwd )
+-- >>> let fwds = [fwd "user1@exAmPle.com." "user2@examPle.net"]
+-- >>> let mx_set = Set.fromList ["mx.EXAMPLE.com"]
+-- >>> let example_mx_pairs = [("Example.com", mx_set)]
+-- >>> let mx_map = Map.fromList example_mx_pairs
+-- >>> let droplist = MxList ["mx.EXAMple.com", "mx2.example.COM"]
+-- >>> map pretty_print (dropby_mxlist droplist mx_map fwds)
+-- []
+--
+-- This time it shouldn't be dropped, because ["mx.example.com"] is
+-- not contained in ["nope.example.com"]:
+--
+-- >>> import qualified Data.Map as Map ( fromList )
+-- >>> import qualified Data.Set as Set ( fromList )
+-- >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
+-- >>> let mx_set = Set.fromList ["mx.example.com"]
+-- >>> let example_mx_pairs = [("example.com.", mx_set)]
+-- >>> let mx_map = Map.fromList example_mx_pairs
+-- >>> let droplist = MxList ["nope.example.com"]
+-- >>> map pretty_print (dropby_mxlist droplist mx_map fwds)
+-- ["user1@example.com -> user2@example.net"]
+--
+-- Now we check that if a forward has two MXes, one of which appears
+-- in the list of excluded MXes, it doesn't get dropped:
+--
+-- >>> import qualified Data.Map as Map ( fromList )
+-- >>> import qualified Data.Set as Set ( fromList )
+-- >>> let fwds = [fwd "user1@example.com" "user2@example.net"]
+-- >>> let mx_set = Set.fromList ["mx1.example.com", "mx2.example.com"]
+-- >>> let example_mx_pairs = [("example.com.", mx_set)]
+-- >>> let mx_map = Map.fromList example_mx_pairs
+-- >>> let droplist = MxList ["mx1.example.com"]
+-- >>> map pretty_print (dropby_mxlist droplist mx_map fwds)
+-- ["user1@example.com -> user2@example.net"]
+--
+dropby_mxlist :: MxList -> MxSetMap -> [Forward] -> [Forward]
+dropby_mxlist (MxList []) _ = id
+dropby_mxlist (MxList mxs) domain_mx_map =
+ filter (not . is_bad)
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.
+ -- If we don't normalize these first, comparison (isSubsetOf)
+ -- doesn't work so great.
+ mx_set = fromList (map normalize_string_domain mxs)
+
+ -- We perform a lookup using a normalized key, so we'd better
+ -- normalize the keys in the map first!
+ normal_mxmap = mapKeys normalize_string_domain domain_mx_map
+
+ 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_domain d) normal_mxmap) of
+ Nothing -> False -- No domain MX? Don't drop.
+
+ -- We need to normalize the set of MXes for the
+ -- domain, too.
+ Just dmxs ->
+ let ndmxs = (Set.map normalize_string_domain dmxs)
+ in
+ ndmxs `isSubsetOf` mx_set
-- | Given a connection and a 'Configuration', produces the report as
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
+ -- 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 = exclude_mx cfg
+ valid_forwards <- if null (get_mxs exclude_mx_list)
+ then return forwards
+ else do
+ domain_mxs <- mx_set_map domains
+ return $ dropby_mxlist exclude_mx_list domain_mxs forwards
+
+ let remote_forwards = dropby_goto_domains domains valid_forwards
+ let forward_strings = map pretty_print remote_forwards
- return $ (join "\n" forward_strings)
+ -- Don't append the final newline if there's nothing to report.
+ return $ if (null forward_strings)
+ then ""
+ else (join "\n" forward_strings) ++ "\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"
+ "user7@example.com -> user8@example.net\n"
projects / list-remote-forwards.git / commitdiff