Concurrent readFile blocks on Windows

[Bodigrim]

Concurrent System.IO.readFile of the same file works fine on Windows:

#!/usr/bin/env cabal
{- cabal:
build-depends: base, tasty, tasty-hunit, file-io, filepath
ghc-options: -threaded -rtsopts "-with-rtsopts=-N10"
-}

{-# LANGUAGE QuasiQuotes #-}

import Test.Tasty
import Test.Tasty.HUnit
import System.OsPath (osp)
import qualified System.File.OsPath
import System.IO

main :: IO ()
main = do
  writeFile "foo" ""
  defaultMain $ testGroup "All"
    [ testGroup "System.IO"
    $ map (const $ testCase "foo" (System.IO.openFile "foo" ReadMode >>= hClose)) [0..99]
    ]

But concurrent System.File.OsPath.openFile fail intermittently with resource busy (file is locked):

#!/usr/bin/env cabal
{- cabal:
build-depends: base, tasty, tasty-hunit, file-io, filepath
ghc-options: -threaded -rtsopts "-with-rtsopts=-N10"
-}

{-# LANGUAGE QuasiQuotes #-}

import Test.Tasty
import Test.Tasty.HUnit
import System.OsPath (osp)
import qualified System.File.OsPath
import System.IO

main :: IO ()
main = do
  writeFile "foo" ""
  defaultMain $ testGroup "All"
    [ testGroup "System.File.OsPath"
    $ map (const $ testCase "foo" (System.File.OsPath.openFile [osp|foo|] ReadMode >>= hClose)) [0..99]
    ]

[hasufell]

I've tracked this down to Win32.hANDLEToHandle. If I just keep using the proper windows handle pointer, there's no concurrency issue. So this must be related to:

https://github.com/haskell/win32/blob/22d1510656932a0e1b83d81b0b2e7d8217a16a6c/System/Win32/Types.hsc#L284-L330

@Mistuke

[hasufell]

It seems this is expected behavior in a way.

In System.Win32.Types:

hANDLEToHandle :: HANDLE -> IO Handle
hANDLEToHandle handle = posix
  where
    posix = _open_osfhandle (fromIntegral (ptrToIntPtr handle))
                            (#const _O_BINARY) >>= fdToHandle

Then in base, we follow the breadcrumbs in GHC.IO.Handle.FD:

fdToHandle :: Posix.FD -> IO Handle
fdToHandle fdint = do
   iomode <- Posix.fdGetMode fdint
   (fd,fd_type) <- FD.mkFD fdint iomode Nothing
            False{-is_socket-}
              -- NB. the is_socket flag is False, meaning that:
              --  on Windows we're guessing this is not a socket (XXX)
            False{-is_nonblock-}
              -- file descriptors that we get from external sources are
              -- not put into non-blocking mode, because that would affect
              -- other users of the file descriptor
   let fd_str = "<file descriptor: " ++ show fd ++ ">"
   mkHandleFromFD fd fd_type fd_str iomode False{-non-block-}
                  Nothing -- bin mode

And finally GHC.IO.FD (see the haddock and the lockFile call):

-- | Make a 'FD' from an existing file descriptor.  Fails if the FD
-- refers to a directory.  If the FD refers to a file, `mkFD` locks
-- the file according to the Haskell 2010 single writer/multiple reader
-- locking semantics (this is why we need the `IOMode` argument too).
mkFD :: CInt
     -> IOMode
     -> Maybe (IODeviceType, CDev, CIno)
     -- the results of fdStat if we already know them, or we want
     -- to prevent fdToHandle_stat from doing its own stat.
     -- These are used for:
     --   - we fail if the FD refers to a directory
     --   - if the FD refers to a file, we lock it using (cdev,cino)
     -> Bool   -- ^ is a socket (on Windows)
     -> Bool   -- ^ is in non-blocking mode on Unix
     -> IO (FD,IODeviceType)

mkFD fd iomode mb_stat is_socket is_nonblock = do

    let _ = (is_socket, is_nonblock) -- warning suppression

    (fd_type,dev,ino) <-
        case mb_stat of
          Nothing   -> fdStat fd
          Just stat -> return stat

    let write = case iomode of
                   ReadMode -> False
                   _ -> True

    case fd_type of
        Directory ->
           ioException (IOError Nothing InappropriateType "openFile"
                           "is a directory" Nothing Nothing)

        -- regular files need to be locked
        RegularFile -> do
           -- On Windows we need an additional call to get a unique device id
           -- and inode, since fstat just returns 0 for both.
           -- See also Note [RTS File locking]
           (unique_dev, unique_ino) <- getUniqueFileInfo fd dev ino
           r <- lockFile (fromIntegral fd) unique_dev unique_ino
                         (fromBool write)
           when (r == -1)  $
                ioException (IOError Nothing ResourceBusy "openFile"
                                   "file is locked" Nothing Nothing)

        _other_type -> return ()

#if defined(mingw32_HOST_OS)
    when (not is_socket) $ setmode fd True >> return ()
#endif

    return (FD{ fdFD = fd,
#if !defined(mingw32_HOST_OS)
                fdIsNonBlocking = fromEnum is_nonblock
#else
                fdIsSocket_ = fromEnum is_socket
#endif
              },
            fd_type)

As can bee seen, we indeed get a lock:

           r <- lockFile (fromIntegral fd) unique_dev unique_ino
                         (fromBool write)
           when (r == -1)  $
                ioException (IOError Nothing ResourceBusy "openFile"
                                   "file is locked" Nothing Nothing)

And since the IOMode can't be properly reconstructed from a windows handle, it just assumes ReadWrite and we end up with a lock (see fromBool write).

---

The only two ways I see around this is to:

• try to use the native IO manager, which follows a different codepath (but has other issues and needs to be enabled by the user... I had no luck)
• keep openFile broken, but re-implement readFile, writeFile etc in a more low-level manner without using Haskell Handles (that might be some work and cause other unknown issues)

[hasufell]

Well, the third option is to send a patch to Win32, so that is uses the more powerful fdToHandle', which allows to explicitly pass the iomode parameter.

[hasufell]

Proposed low-level fix in this library: ce3ac73