From: Michael Orlitzky Date: Tue, 22 Apr 2014 15:28:02 +0000 (-0400) Subject: Move most of the report functionality into its own module. X-Git-Tag: 0.0.3~23 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=0f6ab35ca71299d1c9db63a12df2329acf123284;p=mailbox-count.git Move most of the report functionality into its own module. Add an HUnit test suite (with sqlite3 database fixture). Add a .ghci file. Get the detail report working. --- diff --git a/.ghci b/.ghci new file mode 100644 index 0000000..28e5c32 --- /dev/null +++ b/.ghci @@ -0,0 +1,8 @@ +:set -isrc -idist/build/autogen +:load src/Main.hs +:load src/Report.hs + +import Database.HDBC +import Database.HDBC.Sqlite3 + +:set prompt "mailbox-count> " diff --git a/mailbox-count.cabal b/mailbox-count.cabal index 87688e8..f80f2b7 100644 --- a/mailbox-count.cabal +++ b/mailbox-count.cabal @@ -11,6 +11,7 @@ category: Mail, Utils build-type: Simple extra-source-files: doc/man1/mailbox-count.1 + test/fixtures/postfixadmin.sqlite3 synopsis: Count mailboxes in a SQL database. description: @@ -25,14 +26,22 @@ executable mailbox-count directory == 1.2.*, filepath == 1.3.*, HDBC == 2.4.*, - HDBC-postgresql == 2.3.* + HDBC-postgresql == 2.3.*, + HDBC-sqlite3 == 2.3.*, + MissingH == 1.2.*, + tasty == 0.8.*, + tasty-hunit == 0.8.* main-is: Main.hs hs-source-dirs: src/ - --other-modules: + other-modules: + Configuration + CommandLine + OptionalConfiguration + Report ghc-options: -Wall @@ -51,6 +60,39 @@ executable mailbox-count -optc-march=native +test-suite testsuite + type: exitcode-stdio-1.0 + hs-source-dirs: src test + main-is: TestSuite.hs + build-depends: + base == 4.*, + cmdargs == 0.10.*, + configurator == 0.2.*, + containers == 0.5.*, + directory == 1.2.*, + filepath == 1.3.*, + HDBC == 2.4.*, + HDBC-postgresql == 2.3.*, + HDBC-sqlite3 == 2.3.*, + MissingH == 1.2.*, + tasty == 0.8.*, + tasty-hunit == 0.8.* + + -- It's not entirely clear to me why I have to reproduce all of this. + ghc-options: + -Wall + -fwarn-hi-shadowing + -fwarn-missing-signatures + -fwarn-name-shadowing + -fwarn-orphans + -fwarn-type-defaults + -fwarn-tabs + -fwarn-incomplete-record-updates + -fwarn-monomorphism-restriction + -fwarn-unused-do-bind + -O2 + + test-suite doctests type: exitcode-stdio-1.0 hs-source-dirs: test diff --git a/src/Main.hs b/src/Main.hs index af09113..b52bf50 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,178 +1,14 @@ -{-# LANGUAGE PatternGuards #-} - module Main where -import Data.List ( foldl' ) -import qualified Data.Map as Map ( Map, alter, empty ) -import Data.Maybe ( catMaybes ) import Data.Monoid ( (<>) ) -import Database.HDBC ( - IConnection, - SqlValue, - disconnect, - safeFromSql, - quickQuery ) 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 ) - -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. --- --- 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"])] --- -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 "" - 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) - -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) - +import Report ( report ) connection_string :: Configuration -> String connection_string cfg = @@ -209,4 +45,4 @@ main = do conn <- connectPostgreSQL (connection_string cfg) r <- report conn (both cfg) (detail cfg) putStrLn r - disconnect conn +-- disconnect conn diff --git a/src/Report.hs b/src/Report.hs new file mode 100644 index 0000000..e248879 --- /dev/null +++ b/src/Report.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE PatternGuards #-} + +module Report ( + report, + report_tests ) +where + +import Data.List ( foldl' ) +import qualified Data.Map as Map ( Map, alter, empty, foldl, mapWithKey ) +import Data.Maybe ( catMaybes ) +import Data.String.Utils ( join ) +import Database.HDBC ( + IConnection, + SqlValue, + safeFromSql, + quickQuery ) +import Database.HDBC.Sqlite3 ( connectSqlite3 ) +import Test.Tasty ( TestTree, testGroup ) +import Test.Tasty.HUnit ( (@?=), testCase ) + + +-- Type synonyms to make the signatures below a little more clear. +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 + + +summary_header :: String +summary_header = "Summary (number of mailboxes per domain)\n" ++ + "----------------------------------------" + +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 + let report_lines = summary_header : (map show domain_counts) + return $ join "\n" report_lines + where + 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. +-- +-- 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"])] +-- +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 + + +detail_header :: String +detail_header = "Detail (list of all mailboxes by domain)\n" ++ + "----------------------------------------" + +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 + + -- This maps domains to a string listing their users + let domain_report_map = Map.mapWithKey format_domain domain_users_map + let report_body = Map.foldl (++) "" domain_report_map + return $ detail_header ++ report_body + where + query = "SELECT domain,username " ++ + "FROM mailbox " ++ + "ORDER BY domain;" + + format_domain :: Domain -> [Username] -> String + format_domain domain users = + (join "\n" (domain_header : indented_users)) ++ "\n" + where + domain_header = "\n" ++ domain ++ ":" + indented_users = map (" " ++) users + + +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) + + + +-- * Tests + +report_tests :: TestTree +report_tests = + testGroup "Report Tests" [ test_summary_report, test_detail_report ] + + +test_summary_report :: TestTree +test_summary_report = + testCase desc $ do + conn <- connectSqlite3 "test/fixtures/postfixadmin.sqlite3" + actual <- report_summary conn + actual @?= expected + where + desc = "Summary report looks like it should" + expected = summary_header ++ + "\n" ++ + "example.com: 3\n" ++ + "example.net: 2\n" ++ + "example.org: 1" + + +test_detail_report :: TestTree +test_detail_report = + testCase desc $ do + conn <- connectSqlite3 "test/fixtures/postfixadmin.sqlite3" + actual <- report_detail conn + actual @?= expected + where + desc = "Detail report looks like it should" + expected = detail_header ++ + "\n" ++ + "example.com:\n" ++ + " user1\n" ++ + " user3\n" ++ + " user5\n" ++ + "\n" ++ + "example.net:\n" ++ + " user2\n" ++ + " user4\n" ++ + "\n" ++ + "example.org:\n" ++ + " user6\n" diff --git a/test/TestSuite.hs b/test/TestSuite.hs new file mode 100644 index 0000000..50d56b4 --- /dev/null +++ b/test/TestSuite.hs @@ -0,0 +1,9 @@ +import Test.Tasty ( TestTree, defaultMain, testGroup ) + +import Report ( report_tests ) + +tests :: TestTree +tests = testGroup "All tests" [ report_tests ] + +main :: IO () +main = defaultMain tests diff --git a/test/fixtures/postfixadmin.sqlite3 b/test/fixtures/postfixadmin.sqlite3 new file mode 100644 index 0000000..5570886 Binary files /dev/null and b/test/fixtures/postfixadmin.sqlite3 differ