1 files changed, 42 insertions, 0 deletions
diff --git a/testsuite/tests/lib/IO/hClose003.hs b/testsuite/tests/lib/IO/hClose003.hs
new file mode 100644
index 0000000000..cbaf49d6db
--- /dev/null
+++ b/testsuite/tests/lib/IO/hClose003.hs
@@ -0,0 +1,42 @@
+-- Test for #3128, file descriptor leak when hClose fails
+
+import System.IO
+import Control.Exception
+import Data.Char
+
+import System.Posix
+import qualified GHC.IO.Device as IODevice
+import GHC.IO.Handle
+import GHC.IO.Handle.Internals
+import GHC.IO.Handle.Types
+import System.Posix.Internals
+
+main = do
+  (read,write) <- createPipe
+  hread <- fdToHandle read
+  hwrite <- fdToHandle write
+
+        -- close the FD without telling the IO library:
+  showPossibleException (hClose hread)
+  hIsOpen hread >>= print
+
+        -- put some data in the Handle's write buffer:
+  hPutStr hwrite "testing"
+        -- now try to close the Handle:
+  showPossibleException (hClose hwrite)
+  hIsOpen hwrite >>= print
+
+showPossibleException :: IO () -> IO ()
+showPossibleException f = do 
+  e <- try f
+  putStrLn (sanitise (show (e :: Either SomeException ())))
+ where
+  -- we don't care which file descriptor it is
+  sanitise [] = []
+  sanitise (x:xs) = if isDigit x then ('X':(sanitise' xs)) else (x:(sanitise xs))
+  sanitise' [] = []
+  sanitise' (x:xs) = if isDigit x then (sanitise' xs) else (x:(sanitise xs))
+
+naughtyClose h = 
+  withHandle_ "naughtyClose" h $ \ Handle__{haDevice=dev} -> do
+     IODevice.close dev