-{-# LANGUAGE PatternGuards #-}
-
+{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
module 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(..), 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 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
-- 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)
projects / mailbox-count.git / blobdiff