From: Michael Orlitzky Date: Thu, 27 Nov 2014 06:21:58 +0000 (-0500) Subject: Add a doctest test suite. X-Git-Tag: 0.0.1~9 X-Git-Url: http://gitweb.michael.orlitzky.com/?p=list-remote-forwards.git;a=commitdiff_plain;h=8e5a377920002012c38066a2d21b6393a78c677a Add a doctest test suite. Add docs and rc file example for --exclude-mx. Update docs for some functions. Split a few local functions into global ones for testing. Add doctests for existing global functions. --- diff --git a/doc/list-remote-forwardsrc.example b/doc/list-remote-forwardsrc.example index 96a834e..6f11869 100644 --- a/doc/list-remote-forwardsrc.example +++ b/doc/list-remote-forwardsrc.example @@ -18,6 +18,18 @@ # domain_query = "SELECT DISTINCT domain FROM alias;" +# The name of a mail exchange, the forwards of whose domains we should +# ignore. For example, if one mail exchanger, mx1.example.com, has +# strict spam filtering, it may be acceptable to have remote forwarding +# for domains that have mx1.example.com as their mail exchanger (MX +# record). In that case, you might want to exclude those domains from +# the report, by naming mx1.example.com here. +# +# Default: [] (empty) +# +# exclude_mx = ["mx1.example.com"] + + # SQL query used to produce a list of all forwards on the mail # system. This query should return the set of all (address, goto) # triples, where "goto" is the destination address; i.e. to where diff --git a/doc/man1/list-remote-forwards.1 b/doc/man1/list-remote-forwards.1 index fb9fb5c..bcc7b9c 100644 --- a/doc/man1/list-remote-forwards.1 +++ b/doc/man1/list-remote-forwards.1 @@ -49,7 +49,17 @@ server. See the default value for an example. Default: \(dqSELECT domain FROM domain WHERE domain <> 'ALL' ORDER BY domain;\(dq -.IP \fB\-\-forward-query\fR +.IP \fB\-\-exclude-mx\fR,\ \fB-e\fR +The name of a mail exchanger, the forwards of whose domains we should +ignore. For example, if one mail exchanger, mx1.example.com, has +strict spam filtering, it may be acceptable to have remote forwarding +for domains that have mx1.example.com as their mail exchanger (MX +record). In that case, you might want to exclude those domains from +the report by naming mx1.example.com here. + +Default: [] (empty) + +.IP \fB\-\-forward-query\fR,\ \fB-f\fR SQL query used to produce a list of all forwards on the mail system. This query should return the set of all (address, goto) triples, where \(dqgoto\(dq is the destination address; i.e. to where @@ -58,7 +68,7 @@ than one email address, separated by commas. Default: \(dqSELECT address,goto FROM alias ORDER BY address;\(dq -.IP \fB\-\-host\fR +.IP \fB\-\-host\fR,\ \fB-h\fR Hostname where the database is located (Postgres-only). Default: None, a UNIX domain socket connection is attempted (Postgres only) @@ -73,7 +83,7 @@ Port number used to connect to the database (Postgres-only). Default: None, a UNIX domain socket connection is attempted (Postgres only) -.IP \fB\-\-username\fR +.IP \fB\-\-username\fR,\ \fB-u\fR Username used to connect to the database (Postgres-only). Default: The current user diff --git a/list-remote-forwards.cabal b/list-remote-forwards.cabal index e6b4ece..6b85533 100644 --- a/list-remote-forwards.cabal +++ b/list-remote-forwards.cabal @@ -209,6 +209,33 @@ test-suite testsuite -O2 +test-suite doctests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Doctests.hs + build-depends: + base == 4.*, + -- Additional test dependencies. + doctest >= 0.9, + filemanip >= 0.3.6 + + -- It's not entirely clear to me why I have to reproduce all of this. + ghc-options: + -Wall + -fwarn-hi-shadowing + -fwarn-missing-signatures + -fwarn-name-shadowing + -fwarn-orphans + -fwarn-type-defaults + -fwarn-tabs + -fwarn-incomplete-record-updates + -fwarn-monomorphism-restriction + -fwarn-unused-do-bind + -rtsopts + -threaded + -optc-O3 + -optc-march=native + source-repository head type: git diff --git a/src/DNS.hs b/src/DNS.hs index c319a9f..6010fc9 100644 --- a/src/DNS.hs +++ b/src/DNS.hs @@ -8,7 +8,10 @@ import Network.DNS ( makeResolvSeed, withResolver ) --- Slow since we create the resolver every time. + +-- | Retrieve all MX records for the given domain. This is somewhat +-- inefficient, since we create the resolver every time. +-- lookup_mxs :: Domain -> IO [Domain] lookup_mxs domain = do default_rs <- makeResolvSeed defaultResolvConf diff --git a/src/Main.hs b/src/Main.hs index d1d1ea8..13371a8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -12,10 +12,12 @@ import Database.HDBC.Sqlite3 ( connectSqlite3 ) import System.Console.CmdArgs ( def ) import System.Directory ( doesFileExist ) import System.IO ( hPutStrLn, stderr ) + import CommandLine ( get_args ) import Configuration ( Configuration(..), merge_optional ) import qualified OptionalConfiguration as OC ( from_rc ) import Report ( report ) +import String ( trim ) -- | Construct a connection string (postgres-only, for now) from a @@ -23,7 +25,7 @@ import Report ( report ) -- Postgres, and so we want to avoid appending e.g. \"host=\" to the -- connection string if @(host cfg)@ is 'Nothing'. -- --- Examples: +-- ==== __Examples__ -- -- >>> let default_cfg = def :: Configuration -- >>> let cfg = default_cfg { host = Just "localhost" } @@ -37,11 +39,6 @@ connection_string :: Configuration -> String connection_string cfg = trim $ join " " [host_part, port_part, user_part, pw_part, db_part] where - -- | Strip leading/trailing whitespace, and collapse multiple - -- consecutive spaces into one. - trim :: String -> String - trim = unwords . words - host_part = let h = fmap ("host=" ++) (host cfg) in fromMaybe "" h port_part = let p = fmap (("port=" ++) . show) (port cfg) in fromMaybe "" p user_part = let u = fmap ("user=" ++) (username cfg) in fromMaybe "" u @@ -54,7 +51,7 @@ main = do rc_cfg <- OC.from_rc cmd_cfg <- get_args - -- Merge the config file options with the command-line ones, + -- Merge the config file options with the command-line ones, -- prefering the command-line ones. let opt_config = rc_cfg <> cmd_cfg diff --git a/src/MxList.hs b/src/MxList.hs index d79307d..ce0e649 100644 --- a/src/MxList.hs +++ b/src/MxList.hs @@ -27,9 +27,11 @@ newtype MxList = -- | The default (empty) list of MXes. +-- instance Default MxList where def = MxList [] + instance DCT.Configured MxList where -- | This allows us to read a MxList object out of a Configurator -- config file. By default Configurator wouldn't know what to do, diff --git a/src/Report.hs b/src/Report.hs index 82409c4..bceeaf8 100644 --- a/src/Report.hs +++ b/src/Report.hs @@ -30,11 +30,25 @@ 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) -get_domain_list :: IConnection a => a -> String -> IO [Domain] +-- | 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 @@ -55,7 +69,60 @@ get_domain_list conn query = do return domains -get_forward_list :: IConnection a => a -> String -> IO [Forward] +-- | 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 @@ -71,14 +138,22 @@ get_forward_list conn query = do let forwards = concatMap (row_to_forwards . catMaybes) rows return forwards - where - row_to_forwards :: [String] -> [Forward] - row_to_forwards (addr:gotos:_) = - [Forward addr (strip g) | g <- split "," gotos] - row_to_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 @@ -92,20 +167,37 @@ find_remote_forwards domains forwards = _ -> 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 --- 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. + +-- | 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] --- This 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 []) = return filter_by_mx (MxList mxs) = filterM all_mxs_excluded diff --git a/src/String.hs b/src/String.hs new file mode 100644 index 0000000..8945fbd --- /dev/null +++ b/src/String.hs @@ -0,0 +1,19 @@ +-- | String utility functions not available in some library. +-- +module String ( trim ) +where + + +-- | Strip leading/trailing whitespace, and collapse multiple +-- consecutive spaces into one. +-- +-- ==== __Examples__ +-- +-- >>> trim "\thello" +-- "hello" +-- +-- >>> trim "\n\t\nhello, world! " +-- "hello, world!" +-- +trim :: String -> String +trim = unwords . words diff --git a/test/Doctests.hs b/test/Doctests.hs new file mode 100644 index 0000000..d183b4b --- /dev/null +++ b/test/Doctests.hs @@ -0,0 +1,13 @@ +module Main +where + +import Test.DocTest +import System.FilePath.Find ((==?), always, extension, find) + +find_sources :: IO [FilePath] +find_sources = find always (extension ==? ".hs") "src/" + +main :: IO () +main = do + sources <- find_sources + doctest $ ["-isrc", "-idist/build/autogen"] ++ sources