.SH OPTIONS
.IP \fB\-\-both\fR,\ \fB-b\fR
-Produce both summary and detailed reports at the same time.
+Produce both summary and detailed reports.
.IP \fB\-\-detail\fR,\ \fB-d\fR
-Produce a detailed report instead of the (default) summary.
+Produce a detailed report listing all mailboxes by domain.
.SH BUGS
.P
executable mailbox-count
build-depends:
base == 4.*,
- cmdargs == 0.10.*
-
+ cmdargs == 0.10.*,
+ configurator == 0.2.*,
+ containers == 0.5.*,
+ directory == 1.2.*,
+ filepath == 1.3.*,
+ HDBC == 2.4.*,
+ HDBC-postgresql == 2.3.*
main-is:
Main.hs
clean:
runghc Setup.hs clean
- find ./ -name '*.prof' -delete
- find ./ -name '*.o' -delete
- find ./ -name '*.hi' -delete
+ find ./ -type f -name '*.prof' -delete
+ find ./ -type f -name '*.o' -delete
+ find ./ -type f -name '*.hi' -delete
--- /dev/null
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module CommandLine (
+ get_args )
+where
+
+import System.Console.CmdArgs (
+ (&=),
+ cmdArgs,
+ def,
+ details,
+ help,
+ program,
+ summary )
+
+
+-- Get the version from Cabal.
+import Paths_mailbox_count ( version )
+import Data.Version ( showVersion )
+
+import OptionalConfiguration ( OptionalConfiguration(..) )
+
+
+description :: String
+description = "Count mailboxes in a SQL database."
+
+program_name :: String
+program_name = "mailbox-count"
+
+my_summary :: String
+my_summary = program_name ++ "-" ++ (showVersion version)
+
+both_help :: String
+both_help =
+ "Produce both summary and detailed reports"
+
+database_help :: String
+database_help =
+ "The name of the database to which we should connect"
+
+detail_help :: String
+detail_help =
+ "Produce a detailed report listing all mailboxes by domain"
+
+host_help :: String
+host_help =
+ "Hostname where the database is located"
+
+password_help :: String
+password_help =
+ "Password used to connect to the database"
+
+port_help :: String
+port_help =
+ "Port number used to connect to the database"
+
+username_help :: String
+username_help =
+ "Username used to connect to the database"
+
+arg_spec :: OptionalConfiguration
+arg_spec = OptionalConfiguration
+ { both = def &= help both_help,
+ database = def &= help database_help,
+ detail = def &= help detail_help,
+ host = def &= help host_help,
+ password = def &= help password_help,
+ port = def &= help port_help,
+ username = def &= help username_help }
+ &= program program_name
+ &= summary my_summary
+ &= details [description]
+
+get_args :: IO OptionalConfiguration
+get_args = cmdArgs arg_spec
--- /dev/null
+-- | This module defines the 'Configuration' type, which is just a
+-- wrapper around all of the configuration options we accept on the
+-- command line.
+--
+module Configuration (
+ Configuration(..),
+ merge_optional )
+where
+
+import System.Console.CmdArgs.Default ( Default(..) )
+
+import qualified OptionalConfiguration as OC ( OptionalConfiguration(..) )
+
+-- | The main configuration data type. This will be passed to most of
+-- the important functions once it has been created.
+data Configuration =
+ Configuration {
+ both :: Bool,
+ database :: String,
+ detail :: Bool,
+ host :: String,
+ password :: String,
+ port :: Int,
+ username :: String }
+ deriving (Show)
+
+-- | A Configuration with all of its fields set to their default
+-- values.
+instance Default Configuration where
+ def = Configuration {
+ both = def,
+ database = "postfixadmin",
+ detail = def,
+ host = "localhost",
+ password = def,
+ port = 5432,
+ username = "postgres" }
+
+-- | Merge a 'Configuration' with an 'OptionalConfiguration'. This is
+-- more or less the Monoid instance for 'OptionalConfiguration', but
+-- since the two types are different, we have to repeat ourselves.
+merge_optional :: Configuration
+ -> OC.OptionalConfiguration
+ -> Configuration
+merge_optional cfg opt_cfg =
+ Configuration
+ (merge (both cfg) (OC.both opt_cfg))
+ (merge (database cfg) (OC.database opt_cfg))
+ (merge (detail cfg) (OC.detail opt_cfg))
+ (merge (host cfg) (OC.host opt_cfg))
+ (merge (password cfg) (OC.password opt_cfg))
+ (merge (port cfg) (OC.port opt_cfg))
+ (merge (username cfg) (OC.username opt_cfg))
+ where
+ -- | If the thing on the right is Just something, return that
+ -- something, otherwise return the thing on the left.
+ merge :: a -> Maybe a -> a
+ merge x Nothing = x
+ merge _ (Just y) = y
+{-# LANGUAGE PatternGuards #-}
+
module Main
where
+import Data.List ( foldl' )
+import qualified Data.Map as Map ( Map, alter, empty )
+import Data.Maybe ( catMaybes )
+import Data.Monoid ( (<>) )
+import Database.HDBC (
+ IConnection,
+ SqlValue,
+ disconnect,
+ safeFromSql,
+ quickQuery )
+import Database.HDBC.PostgreSQL ( connectPostgreSQL )
+import System.Console.CmdArgs ( def )
+
+import CommandLine ( get_args )
+import Configuration ( Configuration(..), merge_optional )
+import qualified OptionalConfiguration as OC ( from_rc )
+
+type Domain = String
+type Username = String
+type Count = Int
+
+-- | A wrapper around a (domain, count) pair to keep things type-safe.
+data DomainCount = DomainCount Domain Count
+
+instance Show DomainCount where
+ -- | Display a DomainCount in the form \"domain: count\".
+ --
+ -- Examples:
+ --
+ -- >>> let dc = DomainCount "example.com" 100
+ -- >>> show dc
+ -- "example.com: 100"
+ --
+ show (DomainCount domain count) = domain ++ ": " ++ (show count)
+
+
+-- | A wrapper around a (domain, user) pair to keep things type-safe.
+data DomainUser =
+ DomainUser Domain Username
+ deriving (Show)
+
+
+-- | In the detailed report, we store the usernames as a map from a
+-- domain name to a list of usernames. This type synonym is the type
+-- of that map.
+type DomainUserMap = Map.Map Domain [Username]
+
+
+-- | Convert a list of [SqlByteString, SqlInt32] to 'DomainCount's. If
+-- the conversion doesn't work for some reason (bad data, not enough
+-- columns, etc.), we return 'Nothing'.
+--
+-- Examples:
+--
+-- >>> import Database.HDBC ( iToSql, toSql )
+--
+-- >>> list_to_domain_count [toSql "example.com", iToSql 100]
+-- Just example.com: 100
+--
+-- >>> list_to_domain_count [toSql "example.com"]
+-- Nothing
+--
+-- >>> list_to_domain_count [toSql "example.com", toSql "example.com"]
+-- Nothing
+--
+list_to_domain_count :: [SqlValue] -> Maybe DomainCount
+list_to_domain_count (domain:count:_)
+ | Right d <- safeFromSql domain,
+ Right c <- safeFromSql count = Just $ DomainCount d c
+list_to_domain_count _ =
+ Nothing
+
+
+-- | Convert a list of [SqlByteString, SqlByteString] to 'DomainUser's. If
+-- the conversion doesn't work for some reason (bad data, not enough
+-- columns, etc.), we return 'Nothing'.
+--
+-- Examples:
+--
+-- >>> import Database.HDBC ( toSql )
+-- >>>
+-- >>> list_to_domain_user [toSql "example.com", toSql "user1"]
+-- Just (DomainUser "example.com" "user1")
+--
+-- >>> list_to_domain_user [toSql "example.com"]
+-- Nothing
+--
+list_to_domain_user :: [SqlValue] -> Maybe DomainUser
+list_to_domain_user (domain:user:_)
+ | Right d <- safeFromSql domain,
+ Right u <- safeFromSql user = Just $ DomainUser d u
+list_to_domain_user _ =
+ Nothing
+
+
+report_summary :: IConnection a => a -> IO String
+report_summary conn = do
+ list_rows <- quickQuery conn query []
+ let maybe_domain_counts = map list_to_domain_count list_rows
+ let domain_counts = catMaybes maybe_domain_counts
+ return $ header ++ (concatMap show domain_counts)
+ where
+ header = "mailbox-count summary report" ++
+ "----------------------------"
+
+ query = "SELECT domain,COUNT(username) " ++
+ "FROM mailbox " ++
+ "GROUP BY domain "++
+ "ORDER BY domain;"
+
+
+-- | Construct a Domain -> [Username] (a DomainUserMap) map from a
+-- list of 'DomainUser's. We do this with a fold over the list of
+-- 'DomainUser's, appending each new user to the list associated
+-- with the domain that the user is paired with.
+--
+-- The [Username] lists (the values stored in the map) are kept in
+-- the same order as they are given.
+--
+-- Examples:
+--
+-- >>> let du1 = DomainUser "example.com" "user1"
+-- >>> let du2 = DomainUser "example.com" "user2"
+-- >>> let du3 = DomainUser "example.net" "user3"
+-- >>> construct_domain_user_map [du1,du2,du3]
+-- fromList [("example.com",["user1","user2"]),("example.net",["user3"])]
+--
+-- >>> construct_domain_user_map [du2,du1,du3]
+-- fromList [("example.com",["user2","user1"]),("example.net",["user3"])]
+--
+construct_domain_user_map :: [DomainUser] -> DomainUserMap
+construct_domain_user_map dus =
+ foldl' append_this_du Map.empty dus
+ where
+ append_func :: Username -> (Maybe [Username]) -> (Maybe [Username])
+ append_func user maybe_userlist =
+ case maybe_userlist of
+ Just userlist -> Just (userlist ++ [user])
+ Nothing -> Just [user]
+
+ append_this_du :: DomainUserMap -> DomainUser -> DomainUserMap
+ append_this_du du_map (DomainUser domain user) =
+ Map.alter (append_func user) domain du_map
+
+
+report_detail :: IConnection a => a -> IO String
+report_detail conn = do
+ list_rows <- quickQuery conn query []
+ let maybe_domain_users = map list_to_domain_user list_rows
+ let domain_users = catMaybes maybe_domain_users
+ let domain_users_map = construct_domain_user_map domain_users
+ return ""
+ where
+ query = "SELECT domain,username " ++
+ "FROM mailbox " ++
+ "ORDER BY domain;"
+
+
+report_both :: IConnection a => a -> IO String
+report_both conn = do
+ rs <- report_summary conn
+ rd <- report_detail conn
+ return (rs ++ rd)
+
+report :: IConnection a => a -> Bool -> Bool -> IO String
+report conn do_both do_detail =
+ if do_both
+ then (report_both conn)
+ else if do_detail then (report_detail conn) else (report_summary conn)
+
+
+connection_string :: Configuration -> String
+connection_string cfg =
+ "host=" ++ (host cfg) ++ " " ++
+ "port=" ++ (show $ port cfg) ++ " " ++
+ "user=" ++ (username cfg) ++ " " ++
+ "password=" ++ (password cfg) ++ " " ++
+ "dbname=" ++ (database cfg)
+
main :: IO ()
main = do
- putStrLn "Hello, world!"
+ rc_cfg <- OC.from_rc
+ cmd_cfg <- get_args
+
+ -- Merge the config file options with the command-line ones,
+ -- prefering the command-line ones.
+ let opt_config = rc_cfg <> cmd_cfg
+
+ -- Update a default config with any options that have been set in
+ -- either the config file or on the command-line. We initialize
+ -- logging before the missing parameter checks below so that we can
+ -- log the errors.
+ let cfg = (def :: Configuration) `merge_optional` opt_config
+
+ -- Check the optional config for missing required options.
+ --when (isNothing (OC.password opt_config)) $ do
+ -- report_error "No password supplied."
+ -- exitWith (ExitFailure exit_no_password)
+
+ --when (isNothing (OC.username opt_config)) $ do
+ -- report_error "No username supplied."
+ --exitWith (ExitFailure exit_no_username)
+
+ conn <- connectPostgreSQL (connection_string cfg)
+ r <- report conn (both cfg) (detail cfg)
+ putStrLn r
+ disconnect conn
--- /dev/null
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | An OptionalConfiguration is just like a 'Configuration', except
+-- all of its fields are optional. The user can set options in two
+-- places: the command-line, and a configuration file. Obviously if
+-- a parameter is set in one place, it doesn't need to be set in the
+-- other. Thus, the latter needs to be optional.
+--
+
+module OptionalConfiguration (
+ OptionalConfiguration(..),
+ from_rc )
+where
+
+import qualified Data.Configurator as DC (
+ Worth(Optional),
+ load,
+ lookup )
+import Data.Data ( Data )
+import Data.Typeable ( Typeable )
+import Data.Monoid ( Monoid(..) )
+import Paths_mailbox_count ( getSysconfDir )
+import System.Directory ( getHomeDirectory )
+import System.FilePath ( (</>) )
+import System.IO.Error ( catchIOError )
+
+
+-- | The same as Configuration, except everything is optional. It's easy to
+-- merge two of these by simply dropping the Nothings in favor of
+-- the Justs. The 'feed_hosts' are left un-maybed so that cmdargs
+-- can parse more than one of them.
+--
+data OptionalConfiguration =
+ OptionalConfiguration {
+ both :: Maybe Bool,
+ database :: Maybe String,
+ detail :: Maybe Bool,
+ host :: Maybe String,
+ password :: Maybe String,
+ port :: Maybe Int,
+ username :: Maybe String }
+ deriving (Show, Data, Typeable)
+
+
+-- | Combine two Maybes into one, essentially mashing them
+-- together. We give precedence to the second argument when both are
+-- Justs.
+merge_maybes :: (Maybe a) -> (Maybe a) -> (Maybe a)
+merge_maybes Nothing Nothing = Nothing
+merge_maybes (Just x) Nothing = Just x
+merge_maybes Nothing (Just x) = Just x
+merge_maybes (Just _) (Just y) = Just y
+
+
+-- | The Monoid instance for these lets us "combine" two
+-- OptionalConfigurations. The "combine" operation that we'd like to
+-- perform is, essentially, to mash them together. So if we have two
+-- OptionalConfigurations, each half full, we could combine them
+-- into one big one.
+--
+-- This is used to merge command-line and config-file settings.
+--
+instance Monoid OptionalConfiguration where
+ -- | An empty OptionalConfiguration.
+ mempty = OptionalConfiguration
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+
+ -- | Combine @cfg1@ and @cfg2@, giving precedence to @cfg2@.
+ cfg1 `mappend` cfg2 =
+ OptionalConfiguration
+ (merge_maybes (both cfg1) (both cfg2))
+ (merge_maybes (database cfg1) (database cfg2))
+ (merge_maybes (detail cfg1) (detail cfg2))
+ (merge_maybes (host cfg1) (host cfg2))
+ (merge_maybes (password cfg1) (password cfg2))
+ (merge_maybes (port cfg1) (port cfg2))
+ (merge_maybes (username cfg1) (username cfg2))
+
+
+-- | Obtain an OptionalConfiguration from mailbox-countrc in either
+-- the global configuration directory or the user's home
+-- directory. The one in $HOME is prefixed by a dot so that it is
+-- hidden.
+--
+-- We make an attempt at cross-platform compatibility; we will try
+-- to find the correct directory even on Windows. But if the calls
+-- to getHomeDirectory/getSysconfDir fail for whatever reason, we
+-- fall back to using the Unix-specific /etc and $HOME.
+--
+from_rc :: IO OptionalConfiguration
+from_rc = do
+ etc <- catchIOError getSysconfDir (\e -> do
+ putStrLn $ "ERROR: " ++ (show e)
+ return "/etc")
+ home <- catchIOError getHomeDirectory (\e -> do
+ putStrLn $ "ERROR: " ++ (show e)
+ return "$(HOME)")
+ let global_config_path = etc </> "mailbox-countrc"
+ let user_config_path = home </> ".mailbox-countrc"
+ cfg <- DC.load [ DC.Optional global_config_path,
+ DC.Optional user_config_path ]
+ cfg_both <- DC.lookup cfg "both"
+ cfg_database <- DC.lookup cfg "database"
+ cfg_detail <- DC.lookup cfg "detail"
+ cfg_host <- DC.lookup cfg "host"
+ cfg_password <- DC.lookup cfg "password"
+ cfg_port <- DC.lookup cfg "port"
+ cfg_username <- DC.lookup cfg "username"
+
+ return $ OptionalConfiguration
+ cfg_both
+ cfg_database
+ cfg_detail
+ cfg_host
+ cfg_password
+ cfg_port
+ cfg_username
projects / mailbox-count.git / commitdiff