src/Report.hs

   1 {-# LANGUAGE PatternGuards #-}
   2
   3 module Report (
   4   report,
   5   report_tests )
   6 where
   7
   8 import Data.List ( foldl' )
   9 import qualified Data.Map as Map ( Map, alter, empty, foldl, mapWithKey )
  10 import Data.Maybe ( catMaybes )
  11 import Data.String.Utils ( join )
  12 import Database.HDBC (
  13   IConnection,
  14   SqlValue,
  15   safeFromSql,
  16   quickQuery )
  17 import Database.HDBC.Sqlite3 ( connectSqlite3 )
  18 import Test.Tasty ( TestTree, testGroup )
  19 import Test.Tasty.HUnit ( (@?=), testCase )
  20
  21
  22 -- Type synonyms to make the signatures below a little more clear.
  23 type Domain = String
  24 type Username = String
  25 type Count = Int
  26
  27
  28 -- | A wrapper around a (domain, count) pair to keep things type-safe.
  29 data DomainCount = DomainCount Domain Count
  30
  31 instance Show DomainCount where
  32   -- | Display a DomainCount in the form \"domain: count\".
  33   --
  34   --   Examples:
  35   --
  36   --   >>> let dc = DomainCount "example.com" 100
  37   --   >>> show dc
  38   --   "example.com: 100"
  39   --
  40   show (DomainCount domain count) = domain ++ ": " ++ (show count)
  41
  42
  43 -- | A wrapper around a (domain, user) pair to keep things type-safe.
  44 data DomainUser =
  45   DomainUser Domain Username
  46   deriving (Show)
  47
  48
  49 -- | In the detailed report, we store the usernames as a map from a
  50 --   domain name to a list of usernames. This type synonym is the type
  51 --   of that map.
  52 type DomainUserMap = Map.Map Domain [Username]
  53
  54
  55 -- | Convert a list of [SqlByteString, SqlInt32] to 'DomainCount's. If
  56 --   the conversion doesn't work for some reason (bad data, not enough
  57 --   columns, etc.), we return 'Nothing'.
  58 --
  59 --   Examples:
  60 --
  61 --   >>> import Database.HDBC ( iToSql, toSql )
  62 --
  63 --   >>> list_to_domain_count [toSql "example.com", iToSql 100]
  64 --   Just example.com: 100
  65 --
  66 --   >>> list_to_domain_count [toSql "example.com"]
  67 --   Nothing
  68 --
  69 --   >>> list_to_domain_count [toSql "example.com", toSql "example.com"]
  70 --   Nothing
  71 --
  72 list_to_domain_count :: [SqlValue] -> Maybe DomainCount
  73 list_to_domain_count (domain:count:_)
  74   | Right d <- safeFromSql domain,
  75     Right c <- safeFromSql count = Just $ DomainCount d c
  76 list_to_domain_count _ =
  77   Nothing
  78
  79
  80 -- | Convert a list of [SqlByteString, SqlByteString] to 'DomainUser's. If
  81 --   the conversion doesn't work for some reason (bad data, not enough
  82 --   columns, etc.), we return 'Nothing'.
  83 --
  84 --   Examples:
  85 --
  86 --   >>> import Database.HDBC ( toSql )
  87 --   >>>
  88 --   >>> list_to_domain_user [toSql "example.com", toSql "user1"]
  89 --   Just (DomainUser "example.com" "user1")
  90 --
  91 --   >>> list_to_domain_user [toSql "example.com"]
  92 --   Nothing
  93 --
  94 list_to_domain_user :: [SqlValue] -> Maybe DomainUser
  95 list_to_domain_user (domain:user:_)
  96   | Right d <- safeFromSql domain,
  97     Right u <- safeFromSql user = Just $ DomainUser d u
  98 list_to_domain_user _ =
  99   Nothing
 100
 101
 102 summary_header :: String
 103 summary_header = "Summary (number of mailboxes per domain)\n" ++
 104                  "----------------------------------------"
 105
 106 report_summary :: IConnection a => a -> IO String
 107 report_summary conn = do
 108   list_rows <- quickQuery conn query []
 109   let maybe_domain_counts = map list_to_domain_count list_rows
 110   let domain_counts = catMaybes maybe_domain_counts
 111   let report_lines = summary_header : (map show domain_counts)
 112   return $ join "\n" report_lines
 113   where
 114     query = "SELECT domain,COUNT(username) " ++
 115             "FROM mailbox " ++
 116             "GROUP BY domain "++
 117             "ORDER BY domain;"
 118
 119
 120 -- | Construct a Domain -> [Username] (a DomainUserMap) map from a
 121 --   list of 'DomainUser's. We do this with a fold over the list of
 122 --   'DomainUser's, appending each new user to the list associated
 123 --   with the domain that the user is paired with.
 124 --
 125 --   The [Username] lists (the values stored in the map) are kept in
 126 --   the same order as they are given.
 127 --
 128 --   Examples:
 129 --
 130 --   >>> let du1 = DomainUser "example.com" "user1"
 131 --   >>> let du2 = DomainUser "example.com" "user2"
 132 --   >>> let du3 = DomainUser "example.net" "user3"
 133 --   >>> construct_domain_user_map [du1,du2,du3]
 134 --   fromList [("example.com",["user1","user2"]),("example.net",["user3"])]
 135 --
 136 --   >>> construct_domain_user_map [du2,du1,du3]
 137 --   fromList [("example.com",["user2","user1"]),("example.net",["user3"])]
 138 --
 139 construct_domain_user_map :: [DomainUser] -> DomainUserMap
 140 construct_domain_user_map dus =
 141   foldl' append_this_du Map.empty dus
 142   where
 143     append_func :: Username -> (Maybe [Username]) -> (Maybe [Username])
 144     append_func user maybe_userlist =
 145       case maybe_userlist of
 146         Just userlist -> Just (userlist ++ [user])
 147         Nothing       -> Just [user]
 148
 149     append_this_du :: DomainUserMap -> DomainUser -> DomainUserMap
 150     append_this_du du_map (DomainUser domain user) =
 151       Map.alter (append_func user) domain du_map
 152
 153
 154 detail_header :: String
 155 detail_header = "Detail (list of all mailboxes by domain)\n" ++
 156                 "----------------------------------------"
 157
 158 report_detail :: IConnection a => a -> IO String
 159 report_detail conn = do
 160   list_rows <- quickQuery conn query []
 161   let maybe_domain_users = map list_to_domain_user list_rows
 162   let domain_users = catMaybes maybe_domain_users
 163   let domain_users_map = construct_domain_user_map domain_users
 164
 165   -- This maps domains to a string listing their users
 166   let domain_report_map = Map.mapWithKey format_domain domain_users_map
 167   let report_body = Map.foldl (++) "" domain_report_map
 168   return $ detail_header ++ report_body
 169   where
 170     query = "SELECT domain,username " ++
 171             "FROM mailbox " ++
 172             "ORDER BY domain;"
 173
 174     format_domain :: Domain -> [Username] -> String
 175     format_domain domain users =
 176       (join "\n" (domain_header : indented_users)) ++ "\n"
 177       where
 178         domain_header = "\n" ++ domain ++ ":"
 179         indented_users = map ("  " ++) users
 180
 181
 182 report_both :: IConnection a => a -> IO String
 183 report_both conn = do
 184   rs <- report_summary conn
 185   rd <- report_detail conn
 186   return (rs ++ rd)
 187
 188 report :: IConnection a => a -> Bool -> Bool -> IO String
 189 report conn do_both do_detail =
 190   if do_both
 191   then (report_both conn)
 192   else if do_detail then (report_detail conn) else (report_summary conn)
 193
 194
 195
 196 -- * Tests
 197
 198 report_tests :: TestTree
 199 report_tests =
 200   testGroup "Report Tests" [ test_summary_report, test_detail_report ]
 201
 202
 203 test_summary_report :: TestTree
 204 test_summary_report =
 205   testCase desc $ do
 206     conn <- connectSqlite3 "test/fixtures/postfixadmin.sqlite3"
 207     actual <- report_summary conn
 208     actual @?= expected
 209   where
 210     desc = "Summary report looks like it should"
 211     expected = summary_header ++
 212                "\n" ++
 213                "example.com: 3\n" ++
 214                "example.net: 2\n" ++
 215                "example.org: 1"
 216
 217
 218 test_detail_report :: TestTree
 219 test_detail_report =
 220   testCase desc $ do
 221     conn <- connectSqlite3 "test/fixtures/postfixadmin.sqlite3"
 222     actual <- report_detail conn
 223     actual @?= expected
 224   where
 225     desc = "Detail report looks like it should"
 226     expected = detail_header ++
 227                "\n" ++
 228                "example.com:\n" ++
 229                "  user1\n" ++
 230                "  user3\n" ++
 231                "  user5\n" ++
 232                "\n" ++
 233                "example.net:\n" ++
 234                "  user2\n" ++
 235                "  user4\n" ++
 236                "\n" ++
 237                "example.org:\n" ++
 238                "  user6\n"