X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FMain.hs;h=633e969fcef69849fd07ed602990e52a0f49d80f;hb=7a6ba612bdec5ba940dc6f74143ca64a9163fff2;hp=af0911394cc8c84f260a48de5a0dae9d870d4c4e;hpb=72482968102ebd7ad0abeef958fed2a02a126dd2;p=mailbox-count.git

diff --git a/src/Main.hs b/src/Main.hs
index af09113..633e969 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,186 +1,47 @@
-{-# LANGUAGE PatternGuards #-}
-
 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.PostgreSQL ( connectPostgreSQL )
 import System.Console.CmdArgs ( def )
 
 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"])]
+--   >>> 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 [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 ""
+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;"
+    -- | Strip leading/trailing whitespace, and collapse multiple
+    --   consecutive spaces into one.
+    trim :: String -> String
+    trim = unwords . words
 
+    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
 
-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
@@ -209,4 +70,4 @@ main = do
   conn <- connectPostgreSQL (connection_string cfg)
   r <- report conn (both cfg) (detail cfg)
   putStrLn r
-  disconnect conn
+--  disconnect conn