X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FMain.hs;h=2c225aebfa1bd8b4e4af120ca235e7aa63dff4ce;hb=1585e5bef7e46666a8f026a00884323c9834565b;hp=af0911394cc8c84f260a48de5a0dae9d870d4c4e;hpb=72482968102ebd7ad0abeef958fed2a02a126dd2;p=mailbox-count.git diff --git a/src/Main.hs b/src/Main.hs index af09113..2c225ae 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,187 +1,56 @@ -{-# LANGUAGE PatternGuards #-} - -module Main +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +module Main ( main ) where -import Data.List ( foldl' ) -import qualified Data.Map as Map ( Map, alter, empty ) -import Data.Maybe ( catMaybes ) +import Data.Maybe ( fromMaybe ) import Data.Monoid ( (<>) ) -import Database.HDBC ( - IConnection, - SqlValue, - disconnect, - safeFromSql, - quickQuery ) +import Data.String.Utils ( join ) +import Database.HDBC ( SqlError( seNativeError, seErrorMsg ), handleSql ) import Database.HDBC.PostgreSQL ( connectPostgreSQL ) +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 Configuration ( + Configuration( host, port, username, password, database ), + merge_optional ) import qualified OptionalConfiguration as OC ( from_rc ) +import Report ( report ) -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. +-- | Construct a connection string (postgres-only, for now) from a +-- 'Configuration'. All of these are optional, at least for +-- Postgres, and so we want to avoid appending e.g. \"host=\" to the +-- connection string if @(host cfg)@ is 'Nothing'. -- -- 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"])] +-- >>> let default_cfg = def :: Configuration +-- >>> let cfg = default_cfg { host = Just "localhost" } +-- >>> connection_string cfg +-- "host=localhost" +-- >>> let cfg2 = cfg { username = Just "postgres" } +-- >>> connection_string cfg2 +-- "host=localhost user=postgres" -- -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 "" +connection_string :: Configuration -> String +connection_string cfg = + trim $ join " " [host_part, port_part, user_part, pw_part, db_part] 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) + -- | Strip leading/trailing whitespace, and collapse multiple + -- consecutive spaces into one. + trim :: String -> String + trim = unwords . words -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) + 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 + pw_part = let pw = fmap ("password=" ++) (password cfg) in fromMaybe "" pw + db_part = let db = fmap ("dbname=" ++) (database cfg) in fromMaybe "" db -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 rc_cfg <- OC.from_rc @@ -197,16 +66,22 @@ main = do -- 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) + -- If a database name was specified, and that name exists as a file + -- on the system, assume that the user wanted to use SQLite. + handleSql show_sql_error $ do + r <- case (database cfg) of + Nothing -> connectPostgreSQL (connection_string cfg) >>= report cfg - --when (isNothing (OC.username opt_config)) $ do - -- report_error "No username supplied." - --exitWith (ExitFailure exit_no_username) + Just dbname -> do + exists <- doesFileExist dbname + if exists + then connectSqlite3 dbname >>= report cfg + else connectPostgreSQL (connection_string cfg) >>= report cfg - conn <- connectPostgreSQL (connection_string cfg) - r <- report conn (both cfg) (detail cfg) - putStrLn r - disconnect conn + -- The DB connection is implicitly closed when it gets garbage collected. + putStrLn r + + where + show_sql_error :: SqlError -> IO () + show_sql_error se = hPutStrLn stderr $ + "SQL Error (" ++ (show $ seNativeError se) ++ "): " ++ (seErrorMsg se)