Make openFile exception safe wrt #8

System/File/OsPath.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE BangPatterns #-}
 
 module System.File.OsPath (
   openBinaryFile
@@ -16,16 +17,21 @@ module System.File.OsPath (
 , openExistingFile
 ) where
 
+
 import qualified System.File.Platform as P
 
-import Prelude ((.), ($), String, IO, pure, either, const, flip, Maybe(..), fmap, (<$>), id, ioError, (=<<), Bool(..))
+import Prelude ((.), ($), String, IO, ioError, pure, either, const, flip, Maybe(..), fmap, (<$>), id, Bool(..), FilePath, (++), return, show, (>>=))
 import GHC.IO (catchException)
 import GHC.IO.Exception (IOException(..))
+import GHC.IO.Handle (hClose_help)
+import GHC.IO.Handle.Internals (debugIO)
+import GHC.IO.Handle.Types (Handle__, Handle(..))
+import Control.Concurrent.MVar
+import Control.Monad (void, when)
 import Control.DeepSeq (force)
-import Control.Exception (SomeException, try, evaluate, bracket)
-import System.IO (IOMode(..), Handle)
+import Control.Exception (SomeException, try, evaluate, mask, onException)
+import System.IO (IOMode(..), hSetBinaryMode, hClose)
 import System.IO.Unsafe (unsafePerformIO)
-import System.IO (hSetBinaryMode, hClose)
 import System.OsPath as OSP
 import System.OsString.Internal.Types
 
@@ -44,44 +50,37 @@ import qualified Data.ByteString.Lazy as BSL
 -- On POSIX systems, 'openBinaryFile' is an /interruptible operation/ as
 -- described in "Control.Exception".
 openBinaryFile :: OsPath -> IOMode -> IO Handle
-openBinaryFile osfp iomode = augmentError "openBinaryFile" osfp $ openBinaryFile' osfp iomode
+openBinaryFile osfp iomode = augmentError "openBinaryFile" osfp $ withOpenFile' osfp iomode True False pure False
 
-openBinaryFile' :: OsPath -> IOMode -> IO Handle
-openBinaryFile' (OsString fp) iomode =do
-  h <- P.openFile fp iomode
-  hSetBinaryMode h True
-  pure h
 
 -- | Run an action on a file.
 --
 -- The 'Handle' is automatically closed afther the action.
 withFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r
-withFile osfp@(OsString fp) iomode action = either ioError pure =<< (augmentError "withFile" osfp $ bracket
-  (P.openFile fp iomode)
-  hClose
-  (try . action))
+withFile osfp iomode act = (augmentError "withFile" osfp
+    $ withOpenFile' osfp iomode False False (try . act) True)
+  >>= either ioError pure
 
 withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r
-withBinaryFile osfp iomode action = either ioError pure =<< (augmentError "withBinaryFile" osfp $ bracket
-  (openBinaryFile' osfp iomode)
-  hClose
-  (try . action))
+withBinaryFile osfp iomode act = (augmentError "withBinaryFile" osfp
+    $ withOpenFile' osfp iomode True False (try . act) True)
+  >>= either ioError pure
 
 -- | Run an action on a file.
 --
 -- The 'Handle' is not automatically closed to allow lazy IO. Use this
 -- with caution.
 withFile'
   :: OsPath -> IOMode -> (Handle -> IO r) -> IO r
-withFile' osfp@(OsString fp) iomode action = either ioError pure =<< (augmentError "withFile'" osfp $ do
-  h <- P.openFile fp iomode
-  try . action $ h)
+withFile' osfp iomode act = (augmentError "withFile'" osfp
+    $ withOpenFile' osfp iomode False False (try . act) False)
+  >>= either ioError pure
 
 withBinaryFile'
   :: OsPath -> IOMode -> (Handle -> IO r) -> IO r
-withBinaryFile' fp iomode action = either ioError pure =<< (augmentError "withBinaryFile'" fp $ do
-  h <- openBinaryFile' fp iomode
-  try . action $ h)
+withBinaryFile' osfp iomode act = (augmentError "withBinaryFile'" osfp
+    $ withOpenFile' osfp iomode True False (try . act) False)
+  >>= either ioError pure
 
 -- | The 'readFile' function reads a file and returns the contents of the file
 -- as a 'ByteString'. The file is read lazily, on demand.
@@ -118,11 +117,48 @@ appendFile' fp contents = withFile fp AppendMode (`BS.hPut` contents)
 
 -- | Open a file and return the 'Handle'.
 openFile :: OsPath -> IOMode -> IO Handle
-openFile osfp@(OsString fp) = augmentError "openFile" osfp . P.openFile fp
+openFile osfp iomode = augmentError "openFile" osfp $ withOpenFile' osfp iomode False False pure False
+
 
 -- | Open an existing file and return the 'Handle'.
 openExistingFile :: OsPath -> IOMode -> IO Handle
-openExistingFile osfp@(OsString fp) = augmentError "openExistingFile" osfp . P.openExistingFile fp
+openExistingFile osfp iomode = augmentError "openExistingFile" osfp $ withOpenFile' osfp iomode False True pure False
+
+
+-- ---------------------------------------------------------------------------
+-- Internals
+
+handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
+handleFinalizer _fp m = do
+  handle_ <- takeMVar m
+  (handle_', _) <- hClose_help handle_
+  putMVar m handle_'
+  return ()
+
+type HandleFinalizer = FilePath -> MVar Handle__ -> IO ()
+
+-- | Add a finalizer to a 'Handle'. Specifically, the finalizer
+-- will be added to the 'MVar' of a file handle or the write-side
+-- 'MVar' of a duplex handle. See Handle Finalizers for details.
+addHandleFinalizer :: Handle -> HandleFinalizer -> IO ()
+addHandleFinalizer hndl finalizer = do
+  debugIO $ "Registering finalizer: " ++ show filepath
+  void $ mkWeakMVar mv (finalizer filepath mv)
+  where
+    !(filepath, !mv) = case hndl of
+      FileHandle fp m -> (fp, m)
+      DuplexHandle fp _ write_m -> (fp, write_m)
+
+withOpenFile' :: OsPath -> IOMode -> Bool -> Bool -> (Handle -> IO r) -> Bool -> IO r
+withOpenFile' (OsString fp) iomode binary existing action close_finally = mask $ \restore -> do
+  hndl <- if existing
+          then P.openExistingFile fp iomode
+          else P.openFile fp iomode
+  addHandleFinalizer hndl handleFinalizer
+  when binary $ hSetBinaryMode hndl True
+  r <- restore (action hndl) `onException` hClose hndl
+  when close_finally $ hClose hndl
+  pure r
 
 addFilePathToIOError :: String -> OsPath -> IOException -> IOException
 addFilePathToIOError fun fp ioe = unsafePerformIO $ do

posix/System/File/Platform.hs

@@ -2,13 +2,14 @@
 
 module System.File.Platform where
 
-import Control.Exception (try, SomeException)
+import Control.Exception (try, onException, SomeException)
 import GHC.IO.Handle.FD (fdToHandle')
 import System.IO (IOMode(..), Handle)
 import System.Posix.Types (Fd(..))
 import System.Posix.IO.PosixString
     ( defaultFileFlags,
       openFd,
+      closeFd,
       OpenFileFlags(noctty, nonBlock, creat, append, trunc),
       OpenMode(ReadWrite, ReadOnly, WriteOnly) )
 import System.OsPath.Posix ( PosixPath )
@@ -37,7 +38,7 @@ openExistingFile fp iomode = fdToHandle_ iomode fp =<< case iomode of
   df = defaultFileFlags { noctty = True, nonBlock = True, creat = Nothing }
 
 fdToHandle_ :: IOMode -> PosixPath -> Fd -> IO Handle
-fdToHandle_ iomode fp (Fd fd) = do
+fdToHandle_ iomode fp (Fd fd) = (`onException` closeFd (Fd fd)) $ do
     fp'  <- either (const (fmap PS.toChar . PS.unpack $ fp)) id <$> try @SomeException (PS.decodeFS fp)
     fdToHandle' fd Nothing False fp' iomode True
 

windows/System/File/Platform.hsc

@@ -43,11 +43,11 @@ openFile fp iomode = bracketOnError
     toHandle
  where
 #if defined(__IO_MANAGER_WINIO__)
-  toHandle h = do
+  toHandle h = (`onException` Win32.closeHandle h) $ do
     when (iomode == AppendMode ) $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END
     Win32.hANDLEToHandle h
 #else
-  toHandle h = do
+  toHandle h = (`onException` Win32.closeHandle h) $ do
     when (iomode == AppendMode ) $ void $ Win32.setFilePointerEx h 0 Win32.fILE_END
     fd <- _open_osfhandle (fromIntegral (ptrToIntPtr h)) (#const _O_BINARY)
     fp' <- either (const (fmap WS.toChar . WS.unpack $ fp)) id <$> try @SomeException (WS.decodeFS fp)