]> gitweb.michael.orlitzky.com - mailbox-count.git/commitdiff
Begin throwing real code together.
authorMichael Orlitzky <michael@orlitzky.com>
Tue, 22 Apr 2014 01:19:28 +0000 (21:19 -0400)
committerMichael Orlitzky <michael@orlitzky.com>
Tue, 22 Apr 2014 01:19:28 +0000 (21:19 -0400)
doc/man1/mailbox-count.1
mailbox-count.cabal
makefile
src/CommandLine.hs [new file with mode: 0644]
src/Configuration.hs [new file with mode: 0644]
src/Main.hs
src/OptionalConfiguration.hs [new file with mode: 0644]

index f96fcab0e1ad82316518e798e69071b43bfc2d35..c7b6164b0d528a19fc11d53091e3e725968c765d 100644 (file)
@@ -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
index 3dfe80d10adacbae95eeeda9de00cb8c16b72832..87688e8a3aabb944d9c5e164a726e553438e5a5b 100644 (file)
@@ -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
 
index bdedde5f250079072b1d141356aa230981d43ad4..5c6fabb712d4efd901a5e0db35eb5a8660bed911 100644 (file)
--- 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 (file)
index 0000000..8a2a811
--- /dev/null
@@ -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 (file)
index 0000000..2fbc397
--- /dev/null
@@ -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
index d6f7c8fdbf0d3656a49d09c59abc7c2886d0289f..af0911394cc8c84f260a48de5a0dae9d870d4c4e 100644 (file)
@@ -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 (file)
index 0000000..d2b6a05
--- /dev/null
@@ -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