T228

hackage-security/src/Hackage/Security/Util/FileLock.hsc

@@ -12,45 +12,52 @@ module Hackage.Security.Util.FileLock (
   , LockMode(..)
   , hLock
   , hTryLock
+  , hUnlock
   ) where
 
-#if MIN_VERSION_base(4,10,0)
+#if MIN_VERSION_base(4,11,0)
 
 import GHC.IO.Handle.Lock
 
+#elif MIN_VERSION_base(4,10,0)
+
+import GHC.IO.Handle.Lock
+
+-- N.B. base-4.10 (GHC 8.2) didn't have hUnlock. For the time being we simply
+-- define this to be a no-op since we generally close the lock handle anyways.
+--
+-- However, do note that on Windows it can take longer for an outstanding
+-- lock to be released after its handle is closed than if the lock were
+-- explicitly released.
+
+hUnlock :: Handle -> IO ()
+hUnlock hdl = return ()
+
 #else
 
 -- The remainder of this file is a modified copy
--- of GHC.IO.Handle.Lock from ghc-8.2.x
+-- of GHC.IO.Handle.Lock from ghc-8.9.x
 --
 -- The modifications were just to the imports and the CPP, since we do not have
 -- access to the HAVE_FLOCK from the ./configure script. We approximate the
 -- lack of HAVE_FLOCK with @defined(solaris2_HOST_OS) || defined(aix_HOST_OS)@
 -- instead since those are known major Unix platforms lacking @flock()@ or
 -- having broken one.
 
-import Control.Exception (Exception)
-import Data.Typeable
+-- We avoid using #define as it breaks older hsc2hs
 
 #if defined(solaris2_HOST_OS) || defined(aix_HOST_OS)
 
-import Control.Exception (throwIO)
-import System.IO (Handle)
-
-#else
+#include <sys/file.h>
 
 import Data.Bits
 import Data.Function
-import Control.Concurrent.MVar
-
 import Foreign.C.Error
 import Foreign.C.Types
-
-import GHC.IO.Handle.Types
 import GHC.IO.FD
-import GHC.IO.Exception
+import GHC.IO.Handle.FD
 
-#if defined(mingw32_HOST_OS)
+#elif defined(mingw32_HOST_OS)
 
 #if defined(i386_HOST_ARCH)
 ## define WINDOWS_CCONV stdcall
@@ -62,19 +69,29 @@ import GHC.IO.Exception
 
 #include <windows.h>
 
+import Data.Bits
+import Data.Function
+import Foreign.C.Error
+import Foreign.C.Types
 import Foreign.Marshal.Alloc
 import Foreign.Marshal.Utils
-import Foreign.Ptr
+import GHC.IO.FD
+import GHC.IO.Handle.FD
+import GHC.Ptr
 import GHC.Windows
 
-#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */
-
-#include <sys/file.h>
+#else
 
-#endif /* !defined(mingw32_HOST_OS) */
+import GHC.IO (throwIO)
 
-#endif /* !(defined(solaris2_HOST_OS) || defined(aix_HOST_OS)) */
+#endif /* HAVE_FLOCK */
 
+import Data.Functor
+import GHC.Base
+import GHC.Exception
+import GHC.IO.Handle.Types
+import GHC.Show
+import Data.Typeable (Typeable)
 
 -- | Exception thrown by 'hLock' on non-Windows platforms that don't support
 -- 'flock'.
@@ -83,7 +100,6 @@ data FileLockingNotSupported = FileLockingNotSupported
 
 instance Exception FileLockingNotSupported
 
-
 -- | Indicates a mode in which a file should be locked.
 data LockMode = SharedLock | ExclusiveLock
 
@@ -107,25 +123,120 @@ data LockMode = SharedLock | ExclusiveLock
 --
 -- @since 4.10.0.0
 hLock :: Handle -> LockMode -> IO ()
-hLock h mode = lockImpl h "hLock" mode True >> return ()
+hLock h mode = void $ lockImpl h "hLock" mode True
 
 -- | Non-blocking version of 'hLock'.
 --
 -- @since 4.10.0.0
 hTryLock :: Handle -> LockMode -> IO Bool
 hTryLock h mode = lockImpl h "hTryLock" mode False
 
+-- | Release a lock taken with 'hLock' or 'hTryLock'.
+hUnlock :: Handle -> IO ()
+hUnlock = unlockImpl
+
 ----------------------------------------
 
-#if defined(solaris2_HOST_OS) || defined(aix_HOST_OS)
+#if HAVE_OFD_LOCKING
+-- Linux open file descriptor locking.
+--
+-- We prefer this over BSD locking (e.g. flock) since the latter appears to
+-- break in some NFS configurations. Note that we intentionally do not try to
+-- use ordinary POSIX file locking due to its peculiar semantics under
+-- multi-threaded environments.
+
+foreign import ccall interruptible "fcntl"
+  c_fcntl :: CInt -> CInt -> Ptr () -> IO CInt
+
+data FLock  = FLock { l_type   :: CShort
+                    , l_whence :: CShort
+                    , l_start  :: COff
+                    , l_len    :: COff
+                    , l_pid    :: CPid
+                    }
+
+instance Storable FLock where
+    sizeOf _ = #{size flock}
+    alignment _ = #{alignment flock}
+    poke ptr x = do
+        fillBytes ptr 0 (sizeOf x)
+        #{poke flock, l_type}   ptr (l_type x)
+        #{poke flock, l_whence} ptr (l_whence x)
+        #{poke flock, l_start}  ptr (l_start x)
+        #{poke flock, l_len}    ptr (l_len x)
+        #{poke flock, l_pid}    ptr (l_pid x)
+    peek ptr = do
+        FLock <$> #{peek flock, l_type}   ptr
+              <*> #{peek flock, l_whence} ptr
+              <*> #{peek flock, l_start}  ptr
+              <*> #{peek flock, l_len}    ptr
+              <*> #{peek flock, l_pid}    ptr
 
--- | No-op implementation.
 lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
-lockImpl _ _ _ _ = throwIO FileLockingNotSupported
+lockImpl h ctx mode block = do
+  FD{fdFD = fd} <- handleToFd h
+  with flock $ \flock_ptr -> fix $ \retry -> do
+      ret <- with flock $ fcntl fd mode flock_ptr
+      case ret of
+        0 -> return True
+        _ -> getErrno >>= \errno ->
+          case () of
+            _ | not block && errno == eWOULDBLOCK -> return False
+              | errno == eINTR -> retry
+              | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing
+  where
+    flock = FLock { l_type = case mode of
+                               SharedLock -> #{const F_RDLCK}
+                               ExclusiveLock -> #{const F_WRLCK}
+                  , l_whence = #{const SEEK_SET}
+                  , l_start = 0
+                  , l_len = 0
+                  }
+    mode
+      | block     = #{const F_SETLKW}
+      | otherwise = #{const F_SETLK}
+
+unlockImpl :: Handle -> IO ()
+unlockImpl h = do
+  FD{fdFD = fd} <- handleToFd h
+  let flock = FLock { l_type = #{const F_UNLCK}
+                    , l_whence = #{const SEEK_SET}
+                    , l_start = 0
+                    , l_len = 0
+                    }
+  throwErrnoIfMinus1_ "hUnlock"
+      $ with flock $ c_fcntl fd #{const F_SETLK}
+
+#elif HAVE_FLOCK
+
+lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
+lockImpl h ctx mode block = do
+  FD{fdFD = fd} <- handleToFd h
+  let flags = cmode .|. (if block then 0 else #{const LOCK_NB})
+  fix $ \retry -> do
+    ret <- c_flock fd flags
+    case ret of
+      0 -> return True
+      _ -> getErrno >>= \errno ->
+        case () of
+          _ | not block
+            , errno == eAGAIN || errno == eACCES -> return False
+            | errno == eINTR -> retry
+            | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing
+  where
+    cmode = case mode of
+      SharedLock    -> #{const LOCK_SH}
+      ExclusiveLock -> #{const LOCK_EX}
 
-#else /* !(defined(solaris2_HOST_OS) || defined(aix_HOST_OS)) */
+unlockImpl :: Handle -> IO ()
+unlockImpl h = do
+  FD{fdFD = fd} <- handleToFd h
+  throwErrnoIfMinus1_ "flock" $ c_flock fd #{const LOCK_UN}
 
-#if defined(mingw32_HOST_OS)
+foreign import ccall interruptible "flock"
+  c_flock :: CInt -> CInt -> IO CInt
+
+#elif defined(mingw32_HOST_OS)
 
 lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
 lockImpl h ctx mode block = do
@@ -137,23 +248,37 @@ lockImpl h ctx mode block = do
     -- We want to lock the whole file without looking up its size to be
     -- consistent with what flock does. According to documentation of LockFileEx
     -- "locking a region that goes beyond the current end-of-file position is
-    -- not an error", however e.g. Windows 10 doesn't accept maximum possible
-    -- value (a pair of MAXDWORDs) for mysterious reasons. Work around that by
-    -- trying 2^32-1.
-    fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0x0 ovrlpd >>= \b -> case b of
-      True  -> return True
-      False -> getLastError >>= \err -> case () of
-        () | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False
-           | err == #{const ERROR_OPERATION_ABORTED} -> retry
-           | otherwise -> failWith ctx err
+    -- not an error", hence we pass maximum value as the number of bytes to
+    -- lock.
+    fix $ \retry -> do
+      ret <- c_LockFileEx wh flags 0 0xffffffff 0xffffffff ovrlpd
+      case ret of
+        True  -> return True
+        False -> getLastError >>= \err ->
+          case () of
+            _ | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False
+              | err == #{const ERROR_OPERATION_ABORTED} -> retry
+              | otherwise -> failWith ctx err
   where
-    sizeof_OVERLAPPED :: Int
     sizeof_OVERLAPPED = #{size OVERLAPPED}
 
     cmode = case mode of
       SharedLock    -> 0
       ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK}
 
+unlockImpl :: Handle -> IO ()
+unlockImpl h = do
+  FD{fdFD = fd} <- handleToFd h
+  wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) "hUnlock" $ c_get_osfhandle fd
+  allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do
+    fillBytes ovrlpd 0 sizeof_OVERLAPPED
+    ret <- c_UnlockFileEx wh 0 0xffffffff 0xffffffff ovrlpd
+    case ret of
+      True  -> return ()
+      False -> getLastError >>= failWith "hUnlock"
+  where
+    sizeof_OVERLAPPED = #{size OVERLAPPED}
+
 -- https://msdn.microsoft.com/en-us/library/aa297958.aspx
 foreign import ccall unsafe "_get_osfhandle"
   c_get_osfhandle :: CInt -> IO HANDLE
@@ -162,42 +287,20 @@ foreign import ccall unsafe "_get_osfhandle"
 foreign import WINDOWS_CCONV interruptible "LockFileEx"
   c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL
 
-#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */
+-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365716.aspx
+foreign import WINDOWS_CCONV interruptible "UnlockFileEx"
+  c_UnlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL
 
-lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
-lockImpl h ctx mode block = do
-  FD{fdFD = fd} <- handleToFd h
-  let flags = cmode .|. (if block then 0 else #{const LOCK_NB})
-  fix $ \retry -> c_flock fd flags >>= \n -> case n of
-    0 -> return True
-    _ -> getErrno >>= \errno -> case () of
-      () | not block && errno == eWOULDBLOCK -> return False
-         | errno == eINTR -> retry
-         | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing
-  where
-    cmode = case mode of
-      SharedLock    -> #{const LOCK_SH}
-      ExclusiveLock -> #{const LOCK_EX}
+#else
 
-foreign import ccall interruptible "flock"
-  c_flock :: CInt -> CInt -> IO CInt
+-- | No-op implementation.
+lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
+lockImpl _ _ _ _ = throwIO FileLockingNotSupported
 
-#endif /* !defined(mingw32_HOST_OS) */
-
--- | Turn an existing Handle into a file descriptor. This function throws an
--- IOError if the Handle does not reference a file descriptor.
-handleToFd :: Handle -> IO FD
-handleToFd h = case h of
-  FileHandle _ mv -> do
-    Handle__{haDevice = dev} <- readMVar mv
-    case cast dev of
-      Just fd -> return fd
-      Nothing -> throwErr "not a file descriptor"
-  DuplexHandle{} -> throwErr "not a file handle"
-  where
-    throwErr msg = ioException $ IOError (Just h)
-      InappropriateType "handleToFd" msg Nothing Nothing
+-- | No-op implementation.
+unlockImpl :: Handle -> IO ()
+unlockImpl _ = throwIO FileLockingNotSupported
 
-#endif /* defined(solaris2_HOST_OS) || defined(aix_HOST_OS) */
+#endif
 
-#endif /* MIN_VERSION_base */
+#endif /* MIN_VERSION_base(4,10,0) */

hackage-security/src/Hackage/Security/Util/IO.hs

@@ -8,14 +8,13 @@ module Hackage.Security.Util.IO (
   ) where
 
 import Control.Concurrent (threadDelay)
-import Control.Monad (unless)
 import Control.Exception
 import Data.Time
 import System.IO hiding (openTempFile, withFile)
 import System.IO.Error
 
 import Hackage.Security.Util.Path
-import Hackage.Security.Util.FileLock (hLock, LockMode(ExclusiveLock), FileLockingNotSupported)
+import Hackage.Security.Util.FileLock (hLock, LockMode(ExclusiveLock), FileLockingNotSupported, hUnlock)
 
 {-------------------------------------------------------------------------------
   Miscelleneous
@@ -85,7 +84,7 @@ withDirLock dir = bracket takeLock releaseLock . const
 
     me = "Hackage.Security.Util.IO.withDirLock: "
 
-    releaseLock (Just h) = hClose h
+    releaseLock (Just h) = hUnlock h >> hClose h
     releaseLock Nothing  = removeDirectory lock
 
 {-------------------------------------------------------------------------------