From 72482968102ebd7ad0abeef958fed2a02a126dd2 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Mon, 21 Apr 2014 21:19:28 -0400 Subject: [PATCH] Begin throwing real code together. --- doc/man1/mailbox-count.1 | 4 +- mailbox-count.cabal | 9 +- makefile | 6 +- src/CommandLine.hs | 75 +++++++++++++ src/Configuration.hs | 59 ++++++++++ src/Main.hs | 208 ++++++++++++++++++++++++++++++++++- src/OptionalConfiguration.hs | 124 +++++++++++++++++++++ 7 files changed, 477 insertions(+), 8 deletions(-) create mode 100644 src/CommandLine.hs create mode 100644 src/Configuration.hs create mode 100644 src/OptionalConfiguration.hs diff --git a/doc/man1/mailbox-count.1 b/doc/man1/mailbox-count.1 index f96fcab..c7b6164 100644 --- a/doc/man1/mailbox-count.1 +++ b/doc/man1/mailbox-count.1 @@ -20,9 +20,9 @@ With \fI\-\-both\fR, both reports are produced at the same time. .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 diff --git a/mailbox-count.cabal b/mailbox-count.cabal index 3dfe80d..87688e8 100644 --- a/mailbox-count.cabal +++ b/mailbox-count.cabal @@ -19,8 +19,13 @@ description: 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 diff --git a/makefile b/makefile index bdedde5..5c6fabb 100644 --- a/makefile +++ b/makefile @@ -51,6 +51,6 @@ hlint: 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 diff --git a/src/CommandLine.hs b/src/CommandLine.hs new file mode 100644 index 0000000..8a2a811 --- /dev/null +++ b/src/CommandLine.hs @@ -0,0 +1,75 @@ +{-# 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 diff --git a/src/Configuration.hs b/src/Configuration.hs new file mode 100644 index 0000000..2fbc397 --- /dev/null +++ b/src/Configuration.hs @@ -0,0 +1,59 @@ +-- | 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 diff --git a/src/Main.hs b/src/Main.hs index d6f7c8f..af09113 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,6 +1,212 @@ +{-# 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 diff --git a/src/OptionalConfiguration.hs b/src/OptionalConfiguration.hs new file mode 100644 index 0000000..d2b6a05 --- /dev/null +++ b/src/OptionalConfiguration.hs @@ -0,0 +1,124 @@ +{-# 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 -- 2.43.2