io-capture 0.1 → 0.1.0.0
raw patch · 8 files changed
+219/−164 lines, 8 filesdep +bytestringdep +hspecdep +hspec-coredep −directorydep −strictdep ~basedep ~unixsetup-changednew-uploader
Dependencies added: bytestring, hspec, hspec-core, io-capture, streaming-bytestring
Dependencies removed: directory, strict
Dependency ranges changed: base, unix
Files
- LICENSE +21/−28
- Setup.hs +2/−0
- Setup.lhs +0/−3
- System/IO/Capture.hs +0/−87
- io-capture.cabal +46/−14
- src/System/IO/Capture.hs +106/−0
- tests/Spec.hs +44/−0
- tests/Tests.hs +0/−32
LICENSE view
@@ -1,31 +1,24 @@-Copyright Yusaku Hashimoto 2009-+Copyright (c) 2016 Mitchell Rosen All rights reserved. -Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.-- * Neither the name of Yusaku Hashimoto nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.+ * Neither the name of Mitchell Rosen nor the names of other contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
− Setup.lhs
@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain
− System/IO/Capture.hs
@@ -1,87 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module System.IO.Capture (- -- * As usual, You specify import only this function.- capture-- -- * If you want to use lazy reading in the action, I recomend you use these.-, getContents-, hGetContents-, readFile-) where--import Prelude hiding (getContents,readFile,catch)-import System.IO hiding (getContents,hGetContents,readFile)-import qualified System.IO.Strict as SIO (getContents,hGetContents,readFile)- -- in package strict (not in strict-io)-import Control.Exception-import Control.Applicative-import Control.Monad-import System.Directory-import System.Posix--{-|-- Takes an IO as action to run, and a String as given stdin,- then returns whole stdout and stderr as String of tuple.-- > import System.IO.Capture (capture)- >- > main = print =<< capture (getLine >>= putStr) "foobar"- > -- prints ("foobar","")-- WARNING: If Lazy Reading such as @getContents@ was contained in the- action, its behavior is very strange. For detail, see- tests/Tests.hs.-- -}--capture :: IO a -> String -> IO (String,String)-capture action givenInput = - withTempFile $ \(outh,outpath) ->- withTempFile $ \(errh,errpath) -> ignoringException ("","") $ do- let stds = [stdin,stdout,stderr]- stdbufs <- mapM hGetBuffering stds- mapM_ (flip hSetBuffering NoBuffering) stds- (inr,inw) <- createPipe- fd_in <- dup 0- fd_out <- dup 1- fd_err <- dup 2- let capture' = do- inr `dupTo` 0- flip dupTo 1 =<< handleToFd outh- flip dupTo 2 =<< handleToFd errh- fdWrite inw givenInput- closeFd inw- ignoringException () (action >> return ())- (,) <$> readFile outpath <*> readFile errpath- recover = do- fd_in `dupTo` 0- fd_out `dupTo` 1- fd_err `dupTo` 2- forM_ [inr,inw,fd_in,fd_out,fd_err] $ \fd -> ignoringException () $ closeFd fd- zipWithM_ ((ignoringException () .) . hSetBuffering) stds stdbufs- capture' `finally` recover---- override for forcing strictness---- if exception was thrown, they returns empty string.--readFile :: FilePath -> IO String-getContents :: IO String-hGetContents :: Handle -> IO String--readFile = ignoringException "" . SIO.readFile-getContents = ignoringException "" SIO.getContents-hGetContents = ignoringException "" . SIO.hGetContents---- utilities--withTempFile :: ((Handle,FilePath) -> IO a) -> IO a-withTempFile action = do- (path,hdl) <- flip openTempFile "tmpXXXXX" =<< getTemporaryDirectory- action (hdl,path) `finally` (hClose hdl >> removeFile path)--ignoringException :: a -> IO a -> IO a-ignoringException value action = action `catch` do \(_::SomeException) -> return value-
io-capture.cabal view
@@ -1,16 +1,48 @@-name: io-capture-version: 0.1-synopsis: capture IO action's stdout and stderr-description: capture IO action's stdout and stderr-category: System-license: BSD3-license-file: LICENSE-author: Yusaku Hashimoto-maintainer: nonowarn@gmail.com-build-depends: base >= 4 && < 5, unix, strict, directory-build-type: Simple-ghc-options: -Wall+-- This file has been generated from package.yaml by hpack version 0.9.0.+--+-- see: https://github.com/sol/hpack -exposed-modules: System.IO.Capture+name: io-capture+version: 0.1.0.0+synopsis: Capture IO actions' stdout and stderr+description: Capture IO actions' stdout and stderr+homepage: https://github.com/mitchellwrosen/io-capture#readme+bug-reports: https://github.com/mitchellwrosen/io-capture/issues+author: Mitchell Rosen+maintainer: mitchellwrosen@gmail.com+copyright: 2016 Mitchell Rosen+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10 -extra-source-files: tests/Tests.hs+source-repository head+ type: git+ location: https://github.com/mitchellwrosen/io-capture++library+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ base <5.0+ , bytestring <0.11+ , streaming-bytestring <0.2+ , unix <2.8+ exposed-modules:+ System.IO.Capture+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ main-is: tests/Spec.hs+ ghc-options: -Wall+ build-depends:+ base <5.0+ , bytestring <0.11+ , streaming-bytestring <0.2+ , unix <2.8+ , hspec+ , hspec-core+ , io-capture+ default-language: Haskell2010
+ src/System/IO/Capture.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++module System.IO.Capture+ ( capture+ , captureStream+ ) where++import Control.Exception+import Control.Monad+import System.IO (hClose, hPutStr)+import System.Posix.IO+import System.Posix.Process+import System.Posix.Types (ProcessID)++import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Streaming as S++-- For haddocks+import Data.ByteString.Streaming (stdout)++-- | Capture an IO action's @stdout@, @stderr@, and any thrown exception. Waits+-- for the action to complete before returning.+--+-- @+-- > (out, _, _, _) <- 'capture' ('putStrLn' "foo")+-- > 'print' out+-- \"foo\"+--+-- > (_, err, _, _) <- 'capture' ('System.IO.hPutStrLn' 'System.IO.stderr' \"bar\")+-- > 'print' err+-- \"bar\"+--+-- > (_, _, exc, _) <- 'capture' 'undefined'+-- > 'print' exc+-- \"Prelude.undefined\"+-- @+capture :: IO a -> IO (LBS.ByteString, LBS.ByteString, LBS.ByteString, Maybe ProcessStatus)+capture act = do+ (out, err, exc, pid) <- captureStream act+ status <- getProcessStatus True True pid+ (,,,)+ <$> S.toLazy_ out+ <*> S.toLazy_ err+ <*> S.toLazy_ exc+ <*> pure status++-- | Stream an IO action's @stdout@, @stderr@, and any thrown exception. Also+-- returns the spawned process's pid to @wait@ on (otherwise the process will+-- become a zombie after terminating), kill, etc.+--+-- @+-- import qualified Data.ByteString.Streaming as S+--+-- > let action = 'putStrLn' \"foo\" >> 'Control.Concurrent.threadDelay' 1000000+-- > (out, _, _, pid) <- 'captureStream' ('Control.Monad.replicateM_' 5 action)+-- > S.'stdout' out+-- foo+-- foo+-- foo+-- foo+-- foo+-- > 'getProcessStatus' True True pid+-- Just ('Exited' 'System.Exit.ExitSuccess')+-- @+captureStream+ :: IO a+ -> IO ( S.ByteString IO ()+ , S.ByteString IO ()+ , S.ByteString IO ()+ , ProcessID+ )+captureStream act = do+ (out_r, out_w) <- createPipe+ (err_r, err_w) <- createPipe+ (exc_r, exc_w) <- createPipe++ pid <- forkProcess $ do+ closeFd out_r+ closeFd err_r+ closeFd exc_r++ _ <- dupTo out_w stdOutput+ _ <- dupTo err_w stdError++ exc_wh <- fdToHandle exc_w++ void act `catch` \(e :: SomeException) -> hPutStr exc_wh (show e)++ closeFd out_w+ closeFd err_w+ hClose exc_wh++ closeFd out_w+ closeFd err_w+ closeFd exc_w++ out_rh <- fdToHandle out_r+ err_rh <- fdToHandle err_r+ exc_rh <- fdToHandle exc_r++ pure ( S.hGetContents out_rh+ , S.hGetContents err_rh+ , S.hGetContents exc_rh+ , pid+ )
+ tests/Spec.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++import System.IO.Capture++import Control.Concurrent+import Control.Monad+import System.IO+import System.Posix.Process+import System.Posix.Signals+import System.Timeout+import Test.Hspec+import Test.Hspec.Core.Runner++import qualified Data.ByteString.Streaming as S++main :: IO ()+main = hspecWith config $ do+ describe "capture" $ do+ it "captures everything" $ do+ (out, err, exc, _) <- capture (putStr "foo" >> hPutStr stderr "bar" >> undefined)+ out `shouldBe` "foo"+ err `shouldBe` "bar"+ exc `shouldBe` "Prelude.undefined"++ describe "captureStream" $ do+ it "streams output" $ do+ (out, _, _, pid) <- captureStream (forever (putStrLn "foo" >> threadDelay (1*sec)))++ timeout (2*sec) (S.uncons out) >>= \case+ Just (Just _) -> do+ signalProcess sigKILL pid+ _ <- getProcessStatus True True pid+ pure ()+ _ -> expectationFailure "expected a byte, found nothing"+++ where+ -- hspec in color mode messes with stdout+ config = defaultConfig+ { configColorMode = ColorNever }++sec :: Int+sec = 1000000
− tests/Tests.hs
@@ -1,32 +0,0 @@-import Test.Torch-import Control.Monad.Trans-import Prelude hiding (getContents)-import System.IO (hPutStrLn,stderr)-import System.IO.Capture (capture,getContents)--main = run $ do- (out,err) <- liftIO $ capture (putStrLn "foo") []- is out "foo\n" "stdout is captured"- ok (null err) "stderr is also captured"-- (out,err) <- liftIO $ capture (getLine >>= putStrLn >>- getLine >>= hPutStrLn stderr)- "foo\nbar\n"- is out "foo\n" "stdin can be given; stdout is still captured"- is err "bar\n" "stdin can be given; stderr is still captured"-- (out,err) <- liftIO $ capture (getContents >>= putStr) "foobarbaz\nquux\n"- is out "foobarbaz\nquux\n" "lazy io also works; stdout captured"- ok (null err) "lazy io also works; stderr captured"-- (out,err) <- liftIO $ capture (getLine >>= putStrLn >>- getLine >>= hPutStrLn stderr)- "foo\nbar\n"- isn't out "foo\n" "after lazy reading stdin, stdin is not can be given any more"- isn't err "bar\n" "after lazy reading stdin, stdin is not can be given any more"--{-- (out,err) <- liftIO $ capture (putStrLn "foo") []- is out "foo\n" "but stdout is still captured, after lazy reading"- ok (null err) "stderr is still also captured, after lazy reading"- -}