Use in-process file locking on Windows (#4363)
authorPaolo Capriotti <p.capriotti@gmail.com>
Tue, 8 May 2012 13:07:11 +0000 (14:07 +0100)
committerPaolo Capriotti <p.capriotti@gmail.com>
Tue, 8 May 2012 13:08:58 +0000 (14:08 +0100)
GHC/IO/FD.hs
cbits/Win32Utils.c
include/HsBase.h
tests/IO/countReaders001.stdout-mingw32 [deleted file]
tests/IO/openFile005.stdout-mingw32 [deleted file]
tests/IO/openFile007.stdout-mingw32 [deleted file]
tests/IO/readFile001.stdout-mingw32 [deleted file]

index 9422ddf..bbd55cc 100644 (file)
@@ -155,11 +155,7 @@ openFile filepath iomode non_blocking =
     let 
       oflags1 = case iomode of
                   ReadMode      -> read_flags
-#ifdef mingw32_HOST_OS
-                  WriteMode     -> write_flags .|. o_TRUNC
-#else
                   WriteMode     -> write_flags
-#endif
                   ReadWriteMode -> rw_flags
                   AppendMode    -> append_flags
 
@@ -167,7 +163,7 @@ openFile filepath iomode non_blocking =
       binary_flags = o_BINARY
 #else
       binary_flags = 0
-#endif      
+#endif
 
       oflags2 = oflags1 .|. binary_flags
 
@@ -190,14 +186,11 @@ openFile filepath iomode non_blocking =
             `catchAny` \e -> do _ <- c_close fd
                                 throwIO e
 
-#ifndef mingw32_HOST_OS
-        -- we want to truncate() if this is an open in WriteMode, but only
-        -- if the target is a RegularFile.  ftruncate() fails on special files
-        -- like /dev/null.
-    if iomode == WriteMode && fd_type == RegularFile
-      then setSize fD 0
-      else return ()
-#endif
+    -- we want to truncate() if this is an open in WriteMode, but only
+    -- if the target is a RegularFile.  ftruncate() fails on special files
+    -- like /dev/null.
+    when (iomode == WriteMode && fd_type == RegularFile) $
+      setSize fD 0
 
     return (fD,fd_type)
 
@@ -241,30 +234,27 @@ mkFD fd iomode mb_stat is_socket is_nonblock = do
                    ReadMode -> False
                    _ -> True
 
-#ifdef mingw32_HOST_OS
-    _ <- setmode fd True -- unconditionally set binary mode
-    let _ = (dev,ino,write) -- warning suppression
-#endif
-
     case fd_type of
         Directory -> 
            ioException (IOError Nothing InappropriateType "openFile"
                            "is a directory" Nothing Nothing)
 
-#ifndef mingw32_HOST_OS
         -- regular files need to be locked
         RegularFile -> do
-           -- On Windows we use explicit exclusion via sopen() to implement
-           -- this locking (see __hscore_open()); on Unix we have to
-           -- implment it in the RTS.
-           r <- lockFile fd dev ino (fromBool write)
+           -- On Windows we need an additional call to get a unique device id
+           -- and inode, since fstat just returns 0 for both.
+           (unique_dev, unique_ino) <- getUniqueFileInfo fd dev ino
+           r <- lockFile fd unique_dev unique_ino (fromBool write)
            when (r == -1)  $
                 ioException (IOError Nothing ResourceBusy "openFile"
                                    "file is locked" Nothing Nothing)
-#endif
 
         _other_type -> return ()
 
+#ifdef mingw32_HOST_OS
+    _ <- setmode fd True -- unconditionally set binary mode
+#endif
+
     return (FD{ fdFD = fd,
 #ifndef mingw32_HOST_OS
                 fdIsNonBlocking = fromEnum is_nonblock
@@ -274,6 +264,17 @@ mkFD fd iomode mb_stat is_socket is_nonblock = do
               },
             fd_type)
 
+getUniqueFileInfo :: CInt -> CDev -> CIno -> IO (Word64, Word64)
+#ifndef mingw32_HOST_OS
+getUniqueFileInfo _ dev ino = return (fromInteger dev, fromInteger ino)
+#else
+getUniqueFileInfo fd _ _ = do
+  with 0 $ \devptr -> do
+  with 0 $ \inoptr -> do
+  c_getUniqueFileInfo fd devptr inoptr
+  liftM2 (,) (peek devptr) (peek inoptr)
+#endif
+
 #ifdef mingw32_HOST_OS
 foreign import ccall unsafe "__hscore_setmode"
   setmode :: CInt -> Bool -> IO CInt
@@ -304,9 +305,7 @@ stderr = stdFD 2
 
 close :: FD -> IO ()
 close fd =
-#ifndef mingw32_HOST_OS
   (flip finally) (release fd) $
-#endif
   do let closer realFd =
            throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
 #ifdef mingw32_HOST_OS
@@ -318,12 +317,8 @@ close fd =
      closeFdWith closer (fromIntegral (fdFD fd))
 
 release :: FD -> IO ()
-#ifdef mingw32_HOST_OS
-release _ = return ()
-#else
 release fd = do _ <- unlockFile (fdFD fd)
                 return ()
-#endif
 
 #ifdef mingw32_HOST_OS
 foreign import stdcall unsafe "HsBase.h closesocket"
@@ -657,11 +652,11 @@ throwErrnoIfMinus1RetryOnBlock loc f on_block  =
 -- -----------------------------------------------------------------------------
 -- Locking/unlocking
 
-#ifndef mingw32_HOST_OS
 foreign import ccall unsafe "lockFile"
-  lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
+  lockFile :: CInt -> Word64 -> Word64 -> CInt -> IO CInt
 
 foreign import ccall unsafe "unlockFile"
   unlockFile :: CInt -> IO CInt
-#endif
 
+foreign import ccall unsafe "get_unique_file_info"
+  c_getUniqueFileInfo :: CInt -> Ptr Word64 -> Ptr Word64 -> IO ()
index c084bd3..7327f45 100644 (file)
@@ -110,4 +110,21 @@ void maperrno (void)
                        errno = EINVAL;
 }
 
+int get_unique_file_info(int fd, HsWord64 *dev, HsWord64 *ino)
+{
+    HANDLE h = (HANDLE)_get_osfhandle(fd);
+    BY_HANDLE_FILE_INFORMATION info;
+
+    if (GetFileInformationByHandle(h, &info))
+    {
+        *dev = info.dwVolumeSerialNumber;
+        *ino = info.nFileIndexLow
+             | ((HsWord64)info.nFileIndexHigh << 32);
+
+        return 0;
+    }
+
+    return -1;
+}
+
 #endif
index 5c4c141..74ab816 100644 (file)
@@ -529,10 +529,10 @@ extern void __hscore_set_saved_termios(int fd, void* ts);
 #ifdef __MINGW32__
 INLINE int __hscore_open(wchar_t *file, int how, mode_t mode) {
        if ((how & O_WRONLY) || (how & O_RDWR) || (how & O_APPEND))
-         return _wsopen(file,how | _O_NOINHERIT,_SH_DENYRW,mode);
+         return _wsopen(file,how | _O_NOINHERIT,_SH_DENYNO,mode);
           // _O_NOINHERIT: see #2650
        else
-         return _wsopen(file,how | _O_NOINHERIT,_SH_DENYWR,mode);
+         return _wsopen(file,how | _O_NOINHERIT,_SH_DENYNO,mode);
           // _O_NOINHERIT: see #2650
 }
 #else
diff --git a/tests/IO/countReaders001.stdout-mingw32 b/tests/IO/countReaders001.stdout-mingw32
deleted file mode 100644 (file)
index bf80d9d..0000000
+++ /dev/null
@@ -1 +0,0 @@
-Left countReaders001.txt: openFile: permission denied (Permission denied)
diff --git a/tests/IO/openFile005.stdout-mingw32 b/tests/IO/openFile005.stdout-mingw32
deleted file mode 100644 (file)
index bf22798..0000000
+++ /dev/null
@@ -1,12 +0,0 @@
-two writes (should fail)
-Left openFile005.out1: openFile: permission denied (Permission denied)
-write and an append (should fail)
-Left openFile005.out1: openFile: permission denied (Permission denied)
-read/write and a write (should fail)
-Left openFile005.out1: openFile: permission denied (Permission denied)
-read and a read/write (should fail)
-Left openFile005.out1: openFile: permission denied (Permission denied)
-write and a read (should fail)
-Left openFile005.out1: openFile: permission denied (Permission denied)
-two writes, different files (silly, but should succeed)
-two reads, should succeed
diff --git a/tests/IO/openFile007.stdout-mingw32 b/tests/IO/openFile007.stdout-mingw32
deleted file mode 100644 (file)
index 26f0afe..0000000
+++ /dev/null
@@ -1,2 +0,0 @@
-Left openFile007.out: openFile: permission denied (Permission denied)
-hello, world
diff --git a/tests/IO/readFile001.stdout-mingw32 b/tests/IO/readFile001.stdout-mingw32
deleted file mode 100644 (file)
index d086f3a..0000000
+++ /dev/null
@@ -1,30 +0,0 @@
-Left readFile001.out: openFile: permission denied (Permission denied)
--- !!! readFile test
-
-import System.IO
-import System.IO.Error
-
-source   = "readFile001.hs"
-filename = "readFile001.out"
-
-main = do
-  s <- readFile source
-  h <- openFile filename WriteMode
-  hPutStrLn h s
-  hClose h
-  s <- readFile filename
-
-  -- This open should fail, because the readFile hasn't been forced
-  -- and the file is therefore still locked.
-  tryIOError (openFile filename WriteMode) >>= print
-
-  putStrLn s
-
-  -- should be able to open it for writing now, because we've forced the
-  -- whole file.
-  h <- openFile filename WriteMode
-
-  print h
-
-
-{handle: readFile001.out}