diff --git a/src/Test/Util.hs b/src/Test/Util.hs --- a/src/Test/Util.hs +++ b/src/Test/Util.hs @@ -19,6 +19,10 @@ , timeoutProcessMicroseconds , assertProcessMicroseconds + -- * Catching stdout/stderr + , catchStdout + , catchStderr + -- * Exceptions , TestUtilException(..) , testUtilExceptionToException @@ -33,18 +37,21 @@ import Control.Monad.CatchIO as M import Control.Monad.IO.Class import Control.Lens.TH +import qualified Data.ByteString as L import Data.Dynamic import Data.Maybe import Data.Proxy import Data.Time.Clock import System.Exit +import System.Posix.Redirect import System.Process import System.Timeout (timeout) import Text.Printf import Test.Util.Framework ---- Throwing and catching exceptions --- +---------------------------------------------------------------- +-- Throwing and catching exceptions --- -- | Determine whether an exception was caught, and return it if so. isExceptionThrown :: (Functor m, MonadCatchIO m, Exception e) => m a -> m (Either e a) @@ -57,7 +64,11 @@ -- default string, is output. -- -- For more control, see the more fundamental 'isExceptionThrown'. -assertThrown :: (Functor m, MonadCatchIO m, Exception e, Show e) => Maybe String -> Proxy e -> m () -> m () +assertThrown :: (Functor m, MonadCatchIO m, Exception e, Show e) => + Maybe String -- ^ Optional error message. + -> Proxy e -- ^ Type of exception to test for. + -> m () + -> m () assertThrown ms ep m = do either (\e -> flip const (e `asProxyTypeOf` ep) $ return ()) (const . liftIO $ assertString s) =<< isExceptionThrown m where s = fromMaybe "exception NOT thrown" ms @@ -73,11 +84,11 @@ either (liftIO . assertString . sf) (const $ return ()) =<< isExceptionThrown m where sf = fromMaybe (\e -> printf "exception thrown: %s" (show e)) msf - ---- Concurrent TDD --- - +---------------------------------------------------------------- +-- Concurrent TDD ---- Process timing --- +---------------------------------------------------------------- +-- Process timing -- | Time a computation. timeMicroseconds :: (Monad m, MonadIO m) => m a -> m (a, Integer) @@ -135,7 +146,45 @@ assertProcessMicroseconds us ph = do maybe (throwIO $ TimeLimitExceeded Nothing "assertProcessMicroseconds" us) (const $ return ()) =<< timeoutProcessMicroseconds us ph ---- Exceptions --- +---------------------------------------------------------------- +-- Catching stdout/stderr + +-- | A wrapper around @system-posix-riderct@'s redirectStdout to redirect +-- stdout during the execution of a +-- computation and capture the output, restoring the handle upon completion. +-- This may be useful for writing unit tests against some parts of a program +-- that interface with the outside world, such as logging and the CLI frontend. +-- +-- NB: Since the standard file streams are redirected into a 'Knob', all tests +-- that invoke 'catchHandle' must be run in isolation from each other, since +-- only one test can read the handle's output at a time. The author recommends +-- structuring tests such that all such tests under a test tree that uses +-- test-framework's 'mutuallyExclusive' function and whose child nodes all do +-- the same. Both 'stdout' and 'stderr' can be captured at the same time, +-- however. +catchStdout :: IO a -> IO (a, L.ByteString) +catchStdout m = swp <$> redirectStdout m + where swp (a, b) = (b, a) + +-- | A wrapper around @system-posix-riderct@'s redirectStderr to redirect +-- stdout during the execution of a +-- computation and capture the output, restoring the handle upon completion. +-- This may be useful for writing unit tests against some parts of a program +-- that interface with the outside world, such as logging and the CLI frontend. +-- +-- NB: Since the standard file streams are redirected into a 'Knob', all tests +-- that invoke 'catchHandle' must be run in isolation from each other, since +-- only one test can read the handle's output at a time. The author recommends +-- structuring tests such that all such tests under a test tree that uses +-- test-framework's 'mutuallyExclusive' function and whose child nodes all do +-- the same. Both 'stdout' and 'stderr' can be captured at the same time, +-- however. +catchStderr :: IO a -> IO (a, L.ByteString) +catchStderr m = swp <$> redirectStderr m + where swp (a, b) = (b, a) + +---------------------------------------------------------------- +-- Exceptions -- | A class of exceptions for "Tests.Util". data TestUtilException where diff --git a/tdd-util.cabal b/tdd-util.cabal --- a/tdd-util.cabal +++ b/tdd-util.cabal @@ -1,5 +1,5 @@ name: tdd-util -version: 0.2.0.3 +version: 0.3.0.0 cabal-version: >= 1.10 build-type: Simple license: BSD3 @@ -260,6 +260,8 @@ ,time ,parallel-io ,MonadCatchIO-transformers + ,bytestring + ,system-posix-redirect ,HUnit ,test-framework ,test-framework-hunit @@ -295,6 +297,8 @@ ,time ,parallel-io ,MonadCatchIO-transformers + ,bytestring + ,system-posix-redirect ,HUnit ,test-framework ,test-framework-hunit @@ -314,4 +318,4 @@ source-repository head type: git location: git://github.com/bairyn/tdd-util.git - tag: 0.2.0.3 + tag: 0.3.0.0 diff --git a/testsrc/Test/Test/Util.hs b/testsrc/Test/Test/Util.hs --- a/testsrc/Test/Test/Util.hs +++ b/testsrc/Test/Test/Util.hs @@ -8,11 +8,13 @@ import Control.Monad import Data.Maybe import Data.Proxy +import Data.String +import System.IO import System.Process import Text.Printf import Test.Util -import Test.Util.Framework +import Test.Util.Framework hiding (output) newtype ShowableIO a = ShowableIO (IO a) @@ -134,6 +136,7 @@ assertNotThrown (Nothing :: Maybe (TimeLimitExceeded -> String)) $ do assertProcessMicroseconds cap =<< sleepM ] + , mutuallyExclusive . testGroup "catching output" $ redirectTests ] where cushion :: Integer cushion = 20000 @@ -156,3 +159,28 @@ , create_group = False } return ph + +-- | Group with 'mutuallyExclusive'. +redirectTests :: [TTest] +redirectTests = + [ testCase "catchStdout catches the output of Hello World" $ do + output <- snd <$> catchStdout helloWorld + fromString "Hello, World!\n" @=? output + , testCase "catchStderr catches the output of a program that prints to stderr" $ do + output <- snd <$> catchStderr helloWorldErr + fromString "Hello, World!\n" @=? output + , testCase "catchStdout behaves correctly with exceptions, a test in the middle of other redirectHandle tests" $ do + assertThrown Nothing (Proxy :: Proxy IOError) $ do + output <- snd <$> catchStdout (throwIO . userError $ "User error!") + fromString "This is not the output." @=? output + , testCase "no stderr is received from hellowWorld" $ do + output <- snd <$> catchStderr helloWorld + fromString "" @=? output + , testCase "no stdout is received from hellowWorldErr" $ do + output <- snd <$> catchStdout helloWorldErr + fromString "" @=? output + ] + where helloWorld :: IO () + helloWorld = putStrLn "Hello, World!" + helloWorldErr :: IO () + helloWorldErr = hPutStrLn stderr "Hello, World!"