diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,11 @@ +# 0.2.0.0 + +- Breaking change: + - Add `prException` field to `ProcessResult`. + - Now `captureProcessResult` catches any exception (including `ExitCode`) thrown by the given action (usually your `main` function). + - The caught exception is available by `prException` function (except `ExitCode`). +- :new: Add `withEnv` function. + # 0.1.0.0 - Initial release. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -20,3 +20,7 @@ - Can test exit code of your main. - All input and outputs are strict bytestrings except the command line arguments, which is very important when testing with non-UTF8 input and output. - Currently doesn't support suppressing stdout and stderr (Pull request welcome!). + +## Usage + +See [the document of `Test.Main` module](https://hackage.haskell.org/package/main-tester/docs/Test-Main.html). diff --git a/main-tester.cabal b/main-tester.cabal --- a/main-tester.cabal +++ b/main-tester.cabal @@ -1,5 +1,5 @@ name: main-tester -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Capture stdout/stderr/exit code, and replace stdin of your main function. description: See README.md for detail. homepage: https://gitlab.com/igrep/main-tester#readme @@ -23,7 +23,16 @@ , directory default-language: Haskell2010 +flag doctest + description: Build and run doctest. Turn off to avoid error on some environment. + default: False + manual: True + test-suite main-tester-doctest + if flag(doctest) + buildable: True + else + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: test main-is: doctest.hs diff --git a/src/Test/Main.hs b/src/Test/Main.hs --- a/src/Test/Main.hs +++ b/src/Test/Main.hs @@ -5,6 +5,7 @@ captureProcessResult , ProcessResult(..) , withStdin + , withEnv -- ** Re-export from System.Environment , withArgs @@ -15,11 +16,12 @@ import qualified Control.Exception as E +import Control.Monad (mapM, mapM_) import qualified Data.ByteString as B import GHC.IO.Handle (hDuplicate, hDuplicateTo) import System.Directory (removeFile, getTemporaryDirectory) -import System.Environment (withArgs) -import System.Exit (ExitCode(ExitSuccess)) +import System.Environment (withArgs, setEnv, unsetEnv, lookupEnv) +import System.Exit (ExitCode(ExitSuccess, ExitFailure)) import System.IO ( Handle , SeekMode(AbsoluteSeek) @@ -47,7 +49,7 @@ -- -- >>> let main = putStr "hello" -- >>> captureProcessResult main --- ProcessResult {prStdout = "hello", prStderr = "", prExitCode = ExitSuccess} +-- ProcessResult {prStdout = "hello", prStderr = "", prExitCode = ExitSuccess, prException = Nothing} -- -- If the IO action exit with error message, the exit code of result is 'ExitFailure'. -- @@ -55,7 +57,20 @@ -- >>> import System.Exit -- >>> let main = hPutStr stderr "OMG!" >> exitWith (ExitFailure 1) -- >>> captureProcessResult main --- ProcessResult {prStdout = "", prStderr = "OMG!", prExitCode = ExitFailure 1} +-- ProcessResult {prStdout = "", prStderr = "OMG!", prExitCode = ExitFailure 1, prException = Nothing} +-- +-- @since 0.2.0.0 +-- Since v0.2.0.0, this function catches @SomeException@, not only @ExitCode@ +-- to prevent it from losing output when an exception other than @ExitCode@ is thrown. +-- To get the thrown error, use @prException@. +-- +-- Note: 'prStderr' doesn't contain the error message of the thrown exception. +-- See the example below. +-- +-- >>> import Control.Exception +-- >>> let main = ioError $ userError "OMG!" +-- >>> captureProcessResult main +-- ProcessResult {prStdout = "", prStderr = "", prExitCode = ExitFailure 1, prException = Just user error (OMG!)} captureProcessResult :: IO () -> IO ProcessResult captureProcessResult action = do tDir <- getTemporaryDirectory @@ -63,8 +78,7 @@ withBinaryTmpFile tDir "test-stderr" $ \(_ePath, eHd) -> redirectingHandle stdout oHd $ redirectingHandle stderr eHd $ do - prExitCode <- - either id (const ExitSuccess) <$> E.try action + (prExitCode, prException) <- captureExitCodeAndException action prStdout <- readFromHead oHd stdout prStderr <- readFromHead eHd stderr return ProcessResult {..} @@ -75,7 +89,17 @@ hSeek tmpH AbsoluteSeek 0 B.hGetContents tmpH + captureExitCodeAndException act = + (act >> return (ExitSuccess, Nothing)) + `E.catches` [E.Handler forExitCode, E.Handler forSomeException] + forExitCode :: ExitCode -> IO (ExitCode, Maybe E.SomeException) + forExitCode eCode = return (eCode, Nothing) + + forSomeException :: E.SomeException -> IO (ExitCode, Maybe E.SomeException) + forSomeException ex = return (ExitFailure 1, Just ex) + + withBinaryTmpFile :: FilePath -> String -> ((FilePath, Handle) -> IO a) -> IO a withBinaryTmpFile parent name = E.bracket @@ -133,3 +157,35 @@ (openBinaryTempFile tDir "test-stdin") (\(_path, hd) -> hClose hd) (\(path, hd) -> B.hPut hd bs >> return path) + + +-- | +-- Run the given IO action with the specified environment variables set. +-- The environment variables are specified as pairs of @ENV_VAR_NAME@ and @ENV_VAR_VALUE@. +-- If @ENV_VAR_VALUE@ is @Nothing@, the @ENV_VAR_NAME@ is unset with 'unsetEnv'. +-- +-- >>> import System.Environment +-- >>> setEnv "ENV_VAR_TO_UNSET" "value_to_unset" +-- >>> setEnv "ENV_VAR_TO_OVERWRITE" "value_to_overwrite" +-- >>> let main = (print =<< lookupEnv "ENV_VAR_TO_UNSET") >> (print =<< lookupEnv "ENV_VAR_TO_OVERWRITE") +-- >>> withEnv [("ENV_VAR_TO_UNSET", Nothing), ("ENV_VAR_TO_OVERWRITE" , Just "new_value")] main +-- Nothing +-- Just "new_value" +-- >>> main +-- Just "value_to_unset" +-- Just "value_to_overwrite" +withEnv :: [(String, Maybe String)] -> IO a -> IO a +withEnv newVarVals action = + E.bracket + (saveReplaces newVarVals) + replaces + (const action) + + where + saveReplaces = mapM $ \varVal@(var, _val) -> + ((,) <$> pure var <*> lookupEnv var) <* replace varVal + + replaces = mapM_ replace + + replace (var, Just val) = setEnv var val + replace (var, Nothing) = unsetEnv var diff --git a/src/Test/Main/Internal.hs b/src/Test/Main/Internal.hs --- a/src/Test/Main/Internal.hs +++ b/src/Test/Main/Internal.hs @@ -7,6 +7,7 @@ module Test.Main.Internal where +import qualified Control.Exception as E import qualified Data.ByteString.Char8 as B import GHC.Generics (Generic) import System.Exit (ExitCode) @@ -19,15 +20,25 @@ { prStdout :: !B.ByteString , prStderr :: !B.ByteString , prExitCode :: !ExitCode - } deriving (Eq, Show, Generic) + , prException :: !(Maybe E.SomeException) + } deriving (Show, Generic) +-- NOTE: SomeException is not Eq! So can't derive! +instance Eq ProcessResult where + pr1 == pr2 = + prStdout pr1 == prStdout pr2 + && prStderr pr1 == prStderr pr2 + && prStderr pr1 == prStderr pr2 + && prExitCode pr1 == prExitCode pr2 + && fmap show (prException pr1) == fmap show (prException pr2) + -- | Use to avoid errors in related to new line code in tests. -- Currently I use this function only for this module's test. normalizeNewLines :: ProcessResult -> ProcessResult #if defined(mingw32_HOST_OS) normalizeNewLines ProcessResult {..} = - ProcessResult (nl prStdout) (nl prStderr) (prExitCode) + ProcessResult (nl prStdout) (nl prStderr) prExitCode prException where nl = B.concat . B.split '\r' #else diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,6 +1,7 @@ import Control.Monad (mapM_) import Data.ByteString.Char8 (pack) -import System.Environment (getArgs) +import qualified Control.Exception as E +import System.Environment (getArgs, setEnv, lookupEnv) import System.Exit (ExitCode(ExitSuccess, ExitFailure) , exitWith) import System.IO (stderr, hPutStr) import Test.Hspec @@ -34,8 +35,8 @@ main :: IO () main = hspec $ - describe "Test.Main" $ - prop "passes stdin and arguments to the program, and capture stdin data, stderr data, and exitCode" $ + describe "Test.Main" $ do + prop "passes stdin and arguments to the program, and captures stdin data, stderr data, and exit code" $ \(argsA, inDataA, AExitCode eCode) -> do let args = map getPrintableAsciiString argsA inData = pack $ getPrintableAsciiString inDataA @@ -47,4 +48,43 @@ actual <- withStdin inData $ withArgs args $ captureProcessResult testedMain normalizeNewLines actual `shouldBe` - normalizeNewLines (ProcessResult (pack $ unlines args) inData eCode) + normalizeNewLines (ProcessResult (pack $ unlines args) inData eCode Nothing) + + prop "captures stdin data, stderr data, exit code, and thrown exception when the program throws an exception" $ + \(inDataA, errDataA, errorMesage) -> do + let inData = pack $ getPrintableAsciiString inDataA + errDataS = getPrintableAsciiString errDataA + errData = pack errDataS + testedMain = do + putStr =<< getContents + hPutStr stderr errDataS + _ <- fail errorMesage + putStrLn "*** THIS SHOULD NOT BE PRINTED! ***" + + actual <- withStdin inData $ captureProcessResult testedMain + + normalizeNewLines actual `shouldBe` + normalizeNewLines + ( ProcessResult + inData + errData + (ExitFailure 1) + (Just $ E.SomeException $ userError errorMesage) + ) + + it "overwrites or deletes the specified environment variables temporarily" $ do + let vu = "value_to_unset" + vw = "value_to_overwrite" + nv = "new_value" + + setEnv "ENV_VAR_TO_UNSET" vu + setEnv "ENV_VAR_TO_OVERWRITE" vw + + let action = + (,) <$> lookupEnv "ENV_VAR_TO_UNSET" <*> lookupEnv "ENV_VAR_TO_OVERWRITE" + resultMutated <- withEnv + [("ENV_VAR_TO_UNSET", Nothing), ("ENV_VAR_TO_OVERWRITE", Just nv)] + action + + resultMutated `shouldBe` (Nothing, Just nv) + action `shouldReturn` (Just vu, Just vw)