Do not deadlock on huge error output

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

test/PagerSpec.hs

@@ -19,16 +19,33 @@ 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
         process :: CreateProcess
         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 ()