From 814e0bb34287cf62740d58a69b908147fd4bfaec Mon Sep 17 00:00:00 2001
From: Simon Hengel <sol@typeful.net>
Date: Tue, 19 Sep 2023 14:41:36 +0700
Subject: [PATCH] Do not deadlock on huge error output

---
 src/Pager.hs      |  3 ++-
 test/PagerSpec.hs | 25 +++++++++++++++++++++----
 2 files changed, 23 insertions(+), 5 deletions(-)

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 ()