Use GHC.IO.Handle.Lock shim for "dirLock"

Does d91afd3 in better way

See also haskell/cabal#5072 for discussion
about locking. TL;DR if we want to use fcntl, we have to make proper
implementation and audit it.

The directory creation fallback will be used on at least Solaris
and AIX

hackage-security/hackage-security.cabal

@@ -90,10 +90,11 @@ library
                        Hackage.Security.TUF.Targets
                        Hackage.Security.TUF.Timestamp
                        Hackage.Security.Util.Base64
+                       Hackage.Security.Util.Exit
+                       Hackage.Security.Util.FileLock
                        Hackage.Security.Util.JSON
                        Hackage.Security.Util.Stack
                        Hackage.Security.Util.TypedEmbedded
-                       Hackage.Security.Util.Exit
                        Prelude
   -- We support ghc 7.4 (bundled with Cabal 1.14) and up
   build-depends:       base              >= 4.5     && < 5,
@@ -122,6 +123,7 @@ library
                        old-time  >= 1 &&       < 1.2
   else
     build-depends:     directory >= 1.2 && < 1.4
+  build-tool-depends:  hsc2hs:hsc2hs >= 0.67 && <0.69
   hs-source-dirs:      src
   default-language:    Haskell2010
   default-extensions:  DefaultSignatures

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

@@ -0,0 +1,204 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE InterruptibleFFI #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-- | This compat module can be removed once base-4.10 (ghc-8.2) is the minimum
+-- required version. Though note that the locking functionality is not in
+-- public modules in base-4.10, just in the "GHC.IO.Handle.Lock" module.
+--
+-- Copied from @cabal-install@ codebase "Distribution.Client.Compat.FileLock".
+module Hackage.Security.Util.FileLock (
+    FileLockingNotSupported(..)
+  , LockMode(..)
+  , hLock
+  , hTryLock
+  ) where
+
+#if MIN_VERSION_base(4,10,0)
+
+import GHC.IO.Handle.Lock
+
+#else
+
+-- The remainder of this file is a modified copy
+-- of GHC.IO.Handle.Lock from ghc-8.2.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
+
+#if defined(solaris2_HOST_OS) || defined(aix_HOST_OS)
+
+import Control.Exception (throwIO)
+import System.IO (Handle)
+
+#else
+
+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
+
+#if defined(mingw32_HOST_OS)
+
+#if defined(i386_HOST_ARCH)
+## define WINDOWS_CCONV stdcall
+#elif defined(x86_64_HOST_ARCH)
+## define WINDOWS_CCONV ccall
+#else
+# error Unknown mingw32 arch
+#endif
+
+#include <windows.h>
+
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Utils
+import Foreign.Ptr
+import GHC.Windows
+
+#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */
+
+#include <sys/file.h>
+
+#endif /* !defined(mingw32_HOST_OS) */
+
+#endif /* !(defined(solaris2_HOST_OS) || defined(aix_HOST_OS)) */
+
+
+-- | Exception thrown by 'hLock' on non-Windows platforms that don't support
+-- 'flock'.
+data FileLockingNotSupported = FileLockingNotSupported
+  deriving (Typeable, Show)
+
+instance Exception FileLockingNotSupported
+
+
+-- | Indicates a mode in which a file should be locked.
+data LockMode = SharedLock | ExclusiveLock
+
+-- | If a 'Handle' references a file descriptor, attempt to lock contents of the
+-- underlying file in appropriate mode. If the file is already locked in
+-- incompatible mode, this function blocks until the lock is established. The
+-- lock is automatically released upon closing a 'Handle'.
+--
+-- Things to be aware of:
+--
+-- 1) This function may block inside a C call. If it does, in order to be able
+-- to interrupt it with asynchronous exceptions and/or for other threads to
+-- continue working, you MUST use threaded version of the runtime system.
+--
+-- 2) The implementation uses 'LockFileEx' on Windows and 'flock' otherwise,
+-- hence all of their caveats also apply here.
+--
+-- 3) On non-Windows plaftorms that don't support 'flock' (e.g. Solaris) this
+-- function throws 'FileLockingNotImplemented'. We deliberately choose to not
+-- provide fcntl based locking instead because of its broken semantics.
+--
+-- @since 4.10.0.0
+hLock :: Handle -> LockMode -> IO ()
+hLock h mode = lockImpl h "hLock" mode True >> return ()
+
+-- | Non-blocking version of 'hLock'.
+--
+-- @since 4.10.0.0
+hTryLock :: Handle -> LockMode -> IO Bool
+hTryLock h mode = lockImpl h "hTryLock" mode False
+
+----------------------------------------
+
+#if defined(solaris2_HOST_OS) || defined(aix_HOST_OS)
+
+-- | No-op implementation.
+lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
+lockImpl _ _ _ _ = throwIO FileLockingNotSupported
+
+#else /* !(defined(solaris2_HOST_OS) || defined(aix_HOST_OS)) */
+
+#if defined(mingw32_HOST_OS)
+
+lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
+lockImpl h ctx mode block = do
+  FD{fdFD = fd} <- handleToFd h
+  wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd
+  allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do
+    fillBytes ovrlpd (fromIntegral sizeof_OVERLAPPED) 0
+    let flags = cmode .|. (if block then 0 else #{const LOCKFILE_FAIL_IMMEDIATELY})
+    -- 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 >>= \case
+      True  -> return True
+      False -> getLastError >>= \err -> if
+        | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False
+        | err == #{const ERROR_OPERATION_ABORTED} -> retry
+        | otherwise -> failWith ctx err
+  where
+    sizeof_OVERLAPPED = #{size OVERLAPPED}
+
+    cmode = case mode of
+      SharedLock    -> 0
+      ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK}
+
+-- https://msdn.microsoft.com/en-us/library/aa297958.aspx
+foreign import ccall unsafe "_get_osfhandle"
+  c_get_osfhandle :: CInt -> IO HANDLE
+
+-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365203.aspx
+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() */
+
+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 >>= \case
+    0 -> return True
+    _ -> getErrno >>= \errno -> if
+      | 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}
+
+foreign import ccall interruptible "flock"
+  c_flock :: CInt -> CInt -> IO CInt
+
+#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
+
+#endif /* defined(solaris2_HOST_OS) || defined(aix_HOST_OS) */
+
+#endif /* MIN_VERSION_base */

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

@@ -7,12 +7,14 @@ module Hackage.Security.Util.IO (
   , timedIO
   ) where
 
+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 (hTryLock, LockMode(ExclusiveLock), FileLockingNotSupported)
 
 {-------------------------------------------------------------------------------
   Miscelleneous
@@ -30,22 +32,51 @@ handleDoesNotExist act =
         then return Nothing
         else throwIO e
 
--- | Attempt to create a filesystem lock in the specified directory
+-- | Attempt to create a filesystem lock in the specified directory.
 --
+-- This will use OS-specific file locking primitives: "GHC.IO.Handle.Lock" with
+-- @base-4.10" and later or a shim for @base@ versions.
+--
+-- Throws an exception if the lock is already present.
+--
+-- May fallback to locking via creating a directory:
 -- Given a file @/path/to@, we do this by attempting to create the directory
 -- @//path/to/hackage-security-lock@, and deleting the directory again
 -- afterwards. Creating a directory that already exists will throw an exception
 -- on most OSs (certainly Linux, OSX and Windows) and is a reasonably common way
 -- to implement a lock file.
 withDirLock :: Path Absolute -> IO a -> IO a
-withDirLock dir = bracket_ takeLock releaseLock
+withDirLock dir = bracket takeLock releaseLock . const
   where
     lock :: Path Absolute
     lock = dir </> fragment "hackage-security-lock"
 
-    takeLock, releaseLock :: IO ()
-    takeLock    = createDirectory lock
-    releaseLock = removeDirectory lock
+    lock' :: FilePath
+    lock' = toFilePath lock
+
+    takeLock = do
+        h <- openFile lock' ReadWriteMode
+        handle (takeDirLock h) $ do
+            gotlock <- hTryLock h ExclusiveLock
+            unless gotlock $
+                fail $ "hTryLock: lock already exists: " ++ lock'
+            return (Just h)
+
+    takeDirLock :: Handle -> FileLockingNotSupported -> IO (Maybe Handle)
+    takeDirLock h _ = do
+        -- We fallback to directory locking
+        -- so we need to cleanup lock file first: close and remove
+        hClose h
+        handle onIOError (removeFile lock)
+        createDirectory lock
+        return Nothing
+
+    onIOError :: IOError -> IO ()
+    onIOError _ = hPutStrLn stderr
+        "withDirLock: cannot remove lock file before directory lock fallback"
+
+    releaseLock (Just h) = hClose h
+    releaseLock Nothing  = removeDirectory lock
 
 {-------------------------------------------------------------------------------
   Debugging