src/Main.hs

   1 {-# LANGUAGE PatternGuards #-}
   2
   3 module Main
   4 where
   5
   6 import Data.List ( foldl' )
   7 import qualified Data.Map as Map ( Map, alter, empty )
   8 import Data.Maybe ( catMaybes )
   9 import Data.Monoid ( (<>) )
  10 import Database.HDBC (
  11   IConnection,
  12   SqlValue,
  13   disconnect,
  14   safeFromSql,
  15   quickQuery )
  16 import Database.HDBC.PostgreSQL ( connectPostgreSQL )
  17 import System.Console.CmdArgs ( def )
  18
  19 import CommandLine ( get_args )
  20 import Configuration ( Configuration(..), merge_optional )
  21 import qualified OptionalConfiguration as OC ( from_rc )
  22
  23 type Domain = String
  24 type Username = String
  25 type Count = Int
  26
  27 -- | A wrapper around a (domain, count) pair to keep things type-safe.
  28 data DomainCount = DomainCount Domain Count
  29
  30 instance Show DomainCount where
  31   -- | Display a DomainCount in the form \"domain: count\".
  32   --
  33   --   Examples:
  34   --
  35   --   >>> let dc = DomainCount "example.com" 100
  36   --   >>> show dc
  37   --   "example.com: 100"
  38   --
  39   show (DomainCount domain count) = domain ++ ": " ++ (show count)
  40
  41
  42 -- | A wrapper around a (domain, user) pair to keep things type-safe.
  43 data DomainUser =
  44   DomainUser Domain Username
  45   deriving (Show)
  46
  47
  48 -- | In the detailed report, we store the usernames as a map from a
  49 --   domain name to a list of usernames. This type synonym is the type
  50 --   of that map.
  51 type DomainUserMap = Map.Map Domain [Username]
  52
  53
  54 -- | Convert a list of [SqlByteString, SqlInt32] to 'DomainCount's. If
  55 --   the conversion doesn't work for some reason (bad data, not enough
  56 --   columns, etc.), we return 'Nothing'.
  57 --
  58 --   Examples:
  59 --
  60 --   >>> import Database.HDBC ( iToSql, toSql )
  61 --
  62 --   >>> list_to_domain_count [toSql "example.com", iToSql 100]
  63 --   Just example.com: 100
  64 --
  65 --   >>> list_to_domain_count [toSql "example.com"]
  66 --   Nothing
  67 --
  68 --   >>> list_to_domain_count [toSql "example.com", toSql "example.com"]
  69 --   Nothing
  70 --
  71 list_to_domain_count :: [SqlValue] -> Maybe DomainCount
  72 list_to_domain_count (domain:count:_)
  73   | Right d <- safeFromSql domain,
  74     Right c <- safeFromSql count = Just $ DomainCount d c
  75 list_to_domain_count _ =
  76   Nothing
  77
  78
  79 -- | Convert a list of [SqlByteString, SqlByteString] to 'DomainUser's. If
  80 --   the conversion doesn't work for some reason (bad data, not enough
  81 --   columns, etc.), we return 'Nothing'.
  82 --
  83 --   Examples:
  84 --
  85 --   >>> import Database.HDBC ( toSql )
  86 --   >>>
  87 --   >>> list_to_domain_user [toSql "example.com", toSql "user1"]
  88 --   Just (DomainUser "example.com" "user1")
  89 --
  90 --   >>> list_to_domain_user [toSql "example.com"]
  91 --   Nothing
  92 --
  93 list_to_domain_user :: [SqlValue] -> Maybe DomainUser
  94 list_to_domain_user (domain:user:_)
  95   | Right d <- safeFromSql domain,
  96     Right u <- safeFromSql user = Just $ DomainUser d u
  97 list_to_domain_user _ =
  98   Nothing
  99
 100
 101 report_summary :: IConnection a => a -> IO String
 102 report_summary conn = do
 103   list_rows <- quickQuery conn query []
 104   let maybe_domain_counts = map list_to_domain_count list_rows
 105   let domain_counts = catMaybes maybe_domain_counts
 106   return $ header ++ (concatMap show domain_counts)
 107   where
 108     header = "mailbox-count summary report" ++
 109              "----------------------------"
 110
 111     query = "SELECT domain,COUNT(username) " ++
 112             "FROM mailbox " ++
 113             "GROUP BY domain "++
 114             "ORDER BY domain;"
 115
 116
 117 -- | Construct a Domain -> [Username] (a DomainUserMap) map from a
 118 --   list of 'DomainUser's. We do this with a fold over the list of
 119 --   'DomainUser's, appending each new user to the list associated
 120 --   with the domain that the user is paired with.
 121 --
 122 --   The [Username] lists (the values stored in the map) are kept in
 123 --   the same order as they are given.
 124 --
 125 --   Examples:
 126 --
 127 --   >>> let du1 = DomainUser "example.com" "user1"
 128 --   >>> let du2 = DomainUser "example.com" "user2"
 129 --   >>> let du3 = DomainUser "example.net" "user3"
 130 --   >>> construct_domain_user_map [du1,du2,du3]
 131 --   fromList [("example.com",["user1","user2"]),("example.net",["user3"])]
 132 --
 133 --   >>> construct_domain_user_map [du2,du1,du3]
 134 --   fromList [("example.com",["user2","user1"]),("example.net",["user3"])]
 135 --
 136 construct_domain_user_map :: [DomainUser] -> DomainUserMap
 137 construct_domain_user_map dus =
 138   foldl' append_this_du Map.empty dus
 139   where
 140     append_func :: Username -> (Maybe [Username]) -> (Maybe [Username])
 141     append_func user maybe_userlist =
 142       case maybe_userlist of
 143         Just userlist -> Just (userlist ++ [user])
 144         Nothing       -> Just [user]
 145
 146     append_this_du :: DomainUserMap -> DomainUser -> DomainUserMap
 147     append_this_du du_map (DomainUser domain user) =
 148       Map.alter (append_func user) domain du_map
 149
 150
 151 report_detail :: IConnection a => a -> IO String
 152 report_detail conn = do
 153   list_rows <- quickQuery conn query []
 154   let maybe_domain_users = map list_to_domain_user list_rows
 155   let domain_users = catMaybes maybe_domain_users
 156   let domain_users_map = construct_domain_user_map domain_users
 157   return ""
 158   where
 159     query = "SELECT domain,username " ++
 160             "FROM mailbox " ++
 161             "ORDER BY domain;"
 162
 163
 164 report_both :: IConnection a => a -> IO String
 165 report_both conn = do
 166   rs <- report_summary conn
 167   rd <- report_detail conn
 168   return (rs ++ rd)
 169
 170 report :: IConnection a => a -> Bool -> Bool -> IO String
 171 report conn do_both do_detail =
 172   if do_both
 173   then (report_both conn)
 174   else if do_detail then (report_detail conn) else (report_summary conn)
 175
 176
 177 connection_string :: Configuration -> String
 178 connection_string cfg =
 179   "host=" ++ (host cfg) ++ " " ++
 180   "port=" ++ (show $ port cfg) ++ " " ++
 181   "user=" ++ (username cfg) ++ " " ++
 182   "password=" ++ (password cfg) ++ " " ++
 183   "dbname=" ++ (database cfg)
 184
 185 main :: IO ()
 186 main = do
 187   rc_cfg <- OC.from_rc
 188   cmd_cfg <- get_args
 189
 190     -- Merge the config file options with the command-line ones,
 191   -- prefering the command-line ones.
 192   let opt_config = rc_cfg <> cmd_cfg
 193
 194   -- Update a default config with any options that have been set in
 195   -- either the config file or on the command-line.  We initialize
 196   -- logging before the missing parameter checks below so that we can
 197   -- log the errors.
 198   let cfg = (def :: Configuration) `merge_optional` opt_config
 199
 200   -- Check the optional config for missing required options.
 201   --when (isNothing (OC.password opt_config)) $ do
 202   --  report_error "No password supplied."
 203   --  exitWith (ExitFailure exit_no_password)
 204
 205   --when (isNothing (OC.username opt_config)) $ do
 206   --  report_error "No username supplied."
 207   --exitWith (ExitFailure exit_no_username)
 208
 209   conn <- connectPostgreSQL (connection_string cfg)
 210   r <- report conn (both cfg) (detail cfg)
 211   putStrLn r
 212   disconnect conn