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 96a834eb2c2996c474b335d594d06a13ac0b848f..6f118698db1ca1514cbcca58f477ed73c4f24c69 100644 (file)
--- a/doc/list-remote-forwardsrc.example
+++ b/doc/list-remote-forwardsrc.example
@@ -18,6 +18,18 @@
 # domain_query = "SELECT DISTINCT domain FROM alias;"
 
 
 # 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
 # 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 fb9fb5cfbdff05f206ab8b6cc7038ebb1f33482b..bcc7b9c04e754d945f434f49f705a399a2bc1458 100644 (file)
--- 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
 
 
 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
 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
 
 
 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)
 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)
 
 
 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
 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 e6b4ece839e7deafcbfdc758f6ced147491a42ad..6b85533a6b7c197a20ff3db30f299586a15d7573 100644 (file)
--- a/list-remote-forwards.cabal
+++ b/list-remote-forwards.cabal
@@ -209,6 +209,33 @@ test-suite testsuite
     -O2
 
 
     -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
 
 source-repository head
   type: git

diff --git a/src/DNS.hs b/src/DNS.hs
index c319a9fbb387f66ae7a047dee33d119c6cbc5428..6010fc96d6d8e27c7a5377ec25b8dbb5e1622037 100644 (file)
--- a/src/DNS.hs
+++ b/src/DNS.hs
@@ -8,7 +8,10 @@ import Network.DNS (
   makeResolvSeed,
   withResolver )
 
   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
 lookup_mxs :: Domain -> IO [Domain]
 lookup_mxs domain = do
   default_rs <- makeResolvSeed defaultResolvConf

diff --git a/src/Main.hs b/src/Main.hs
index d1d1ea81fa43516bd44b01b294326451b9fbafaf..13371a836d9f7c537583842241db904ec39df1c8 100644 (file)
--- 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 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 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
 
 
 -- | 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'.
 --
 --   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" }
 --
 --   >>> 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
 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
     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
 
   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
 
   -- prefering the command-line ones.
   let opt_config = rc_cfg <> cmd_cfg
 

diff --git a/src/MxList.hs b/src/MxList.hs
index d79307da86a42e459f9cf2ffa5f13449cefbfbc1..ce0e6490c3bd2d64c26beff26574151cc5d31e67 100644 (file)
--- a/src/MxList.hs
+++ b/src/MxList.hs
@@ -27,9 +27,11 @@ newtype MxList =
 
 
 -- | The default (empty) list of MXes.
 
 
 -- | The default (empty) list of MXes.

+--

 instance Default MxList where
   def = MxList []
 
 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,
 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 82409c42ef95a71b7fd346520cc3c85e40805d2b..bceeaf8b6a7faeadf6871fb552d1c921bb26be5b 100644 (file)
--- a/src/Report.hs
+++ b/src/Report.hs
@@ -30,11 +30,25 @@ type Domain = String
 type Address = String
 type Goto = 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)
 
 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
 
 get_domain_list conn query = do
   stmt <- prepare conn query
 


@@ -55,7 +69,60 @@ get_domain_list conn query = do
   return domains
 
 
   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
 
 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
   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
 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
 
 
           _        -> 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
 
 
 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]
 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
 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 (file)
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 (file)
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