diff --git a/src/Pager.hs b/src/Pager.hs index 03c3053..a6c3557 100644 --- a/src/Pager.hs +++ b/src/Pager.hs @@ -3,6 +3,7 @@ module Pager where import Imports import System.IO +import System.IO.Error import System.Process import Control.Concurrent.Async @@ -19,8 +20,8 @@ pagerWith process input = do pid <- newEmptyMVar tid <- async $ withLockedHandle stdin $ do (Just hin, Nothing, Nothing, p) <- createProcess process { delegate_ctlc = True, std_in = CreatePipe } - hPutStr hin input >> hClose hin putMVar pid p + _ <- tryJust (guard . isResourceVanishedError) $ hPutStr hin input >> hClose hin waitForProcess p return $ do readMVar pid >>= terminateProcess diff --git a/test/PagerSpec.hs b/test/PagerSpec.hs index 5786d2f..dea3fb6 100644 --- a/test/PagerSpec.hs +++ b/test/PagerSpec.hs @@ -19,12 +19,16 @@ spec = do describe "pagerWith" $ do it "pipes the provided input into a pager" $ do - (stdoutReadEnd, stdoutWriteEnd) <- createPipe + (readEnd, writeEnd) <- createPipe let process :: CreateProcess - process = (proc "cat" []) { std_out = UseHandle stdoutWriteEnd } - bracket (pagerWith process "foo") id $ \ _ -> do - hGetContents stdoutReadEnd `shouldReturn` "foo" + process = (proc "cat" []) { std_out = UseHandle writeEnd } + + input :: String + input = "foo" + + bracket (pagerWith process input) id $ \ _ -> do + hGetContents readEnd `shouldReturn` input it "can be canceled" $ do let @@ -32,3 +36,16 @@ spec = do process = proc "sleep" ["1d"] cancel <- pagerWith process "foo" timeout cancel `shouldReturn` Just () + + context "when writing to stdin of the subprocess blocks" $ do + it "can still be canceled" $ do + (_, writeEnd) <- createPipe + let + process :: CreateProcess + process = (proc "cat" []) { std_out = UseHandle writeEnd } + + input :: String + input = cycle "foo\n" + + cancel <- pagerWith process input + timeout cancel `shouldReturn` Just ()