Add support for concurrent package db access and updates

Trac issues: #13194

Reviewers: austin, hvr, erikd, bgamari, dfeuer, duncan

Subscribers: DemiMarie, dfeuer, thomie

Differential Revision: https://phabricator.haskell.org/D3090

3 files changed, 194 insertions, 14 deletions

diff --git a/libraries/base/GHC/IO/Handle.hs b/libraries/base/GHC/IO/Handle.hs
index ec376cb8d4..256f802c3d 100644
--- a/libraries/base/GHC/IO/Handle.hs
+++ b/libraries/base/GHC/IO/Handle.hs
@@ -26,12 +26,14 @@ module GHC.IO.Handle (
 
    mkFileHandle, mkDuplexHandle,
 
-   hFileSize, hSetFileSize, hIsEOF, hLookAhead,
+   hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead,
    hSetBuffering, hSetBinaryMode, hSetEncoding, hGetEncoding,
    hFlush, hFlushAll, hDuplicate, hDuplicateTo,
 
    hClose, hClose_help,
 
+   LockMode(..), hLock, hTryLock,
+
    HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,
    SeekMode(..), hSeek, hTell,
 
@@ -54,6 +56,8 @@ import GHC.IO.Encoding
 import GHC.IO.Buffer
 import GHC.IO.BufferedIO ( BufferedIO )
 import GHC.IO.Device as IODevice
+import GHC.IO.Handle.FD
+import GHC.IO.Handle.Lock
 import GHC.IO.Handle.Types
 import GHC.IO.Handle.Internals
 import GHC.IO.Handle.Text
@@ -162,6 +166,15 @@ hIsEOF handle = wantReadableHandle_ "hIsEOF" handle $ \Handle__{..} -> do
              return False
 
 -- ---------------------------------------------------------------------------
+-- isEOF
+
+-- | The computation 'isEOF' is identical to 'hIsEOF',
+-- except that it works only on 'stdin'.
+
+isEOF :: IO Bool
+isEOF = hIsEOF stdin
+
+-- ---------------------------------------------------------------------------
 -- Looking ahead
 
 -- | Computation 'hLookAhead' returns the next character from the handle
diff --git a/libraries/base/GHC/IO/Handle/FD.hs b/libraries/base/GHC/IO/Handle/FD.hs
index b2c971c908..e988b25c9f 100644
--- a/libraries/base/GHC/IO/Handle/FD.hs
+++ b/libraries/base/GHC/IO/Handle/FD.hs
@@ -18,13 +18,13 @@
 module GHC.IO.Handle.FD ( 
   stdin, stdout, stderr,
   openFile, openBinaryFile, openFileBlocking,
-  mkHandleFromFD, fdToHandle, fdToHandle',
-  isEOF
+  mkHandleFromFD, fdToHandle, fdToHandle', handleToFd
  ) where
 
 import GHC.Base
 import GHC.Show
 import Data.Maybe
+import Data.Typeable
 import Foreign.C.Types
 import GHC.MVar
 import GHC.IO
@@ -32,7 +32,6 @@ import GHC.IO.Encoding
 import GHC.IO.Device as IODevice
 import GHC.IO.Exception
 import GHC.IO.IOMode
-import GHC.IO.Handle
 import GHC.IO.Handle.Types
 import GHC.IO.Handle.Internals
 import qualified GHC.IO.FD as FD
@@ -105,15 +104,6 @@ foreign import ccall unsafe "__hscore_setmode"
 #endif
 
 -- ---------------------------------------------------------------------------
--- isEOF
-
--- | The computation 'isEOF' is identical to 'hIsEOF',
--- except that it works only on 'stdin'.
-
-isEOF :: IO Bool
-isEOF = hIsEOF stdin
-
--- ---------------------------------------------------------------------------
 -- Opening and Closing Files
 
 addFilePathToIOError :: String -> FilePath -> IOException -> IOException
@@ -199,7 +189,7 @@ openFile' filepath iomode binary non_blocking = do
 
 
 -- ---------------------------------------------------------------------------
--- Converting file descriptors to Handles
+-- Converting file descriptors from/to Handles
 
 mkHandleFromFD
    :: FD.FD
@@ -283,6 +273,21 @@ fdToHandle fdint = do
    mkHandleFromFD fd fd_type fd_str iomode False{-non-block-} 
                   Nothing -- bin mode
 
+-- | 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.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
+
+
 -- ---------------------------------------------------------------------------
 -- Are files opened by default in text or binary mode, if the user doesn't
 -- specify?
diff --git a/libraries/base/GHC/IO/Handle/Lock.hsc b/libraries/base/GHC/IO/Handle/Lock.hsc
new file mode 100644
index 0000000000..1da0308cdf
--- /dev/null
+++ b/libraries/base/GHC/IO/Handle/Lock.hsc
@@ -0,0 +1,162 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE InterruptibleFFI #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module GHC.IO.Handle.Lock (
+    FileLockingNotSupported(..)
+  , LockMode(..)
+  , hLock
+  , hTryLock
+  ) where
+
+#include "HsBaseConfig.h"
+
+#if HAVE_FLOCK
+
+#include <sys/file.h>
+
+import Data.Bits
+import Data.Function
+import Foreign.C.Error
+import Foreign.C.Types
+import GHC.IO.Exception
+import GHC.IO.FD
+import GHC.IO.Handle.FD
+
+#elif 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 Data.Bits
+import Data.Function
+import Foreign.C.Error
+import Foreign.C.Types
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Utils
+import GHC.IO.Exception
+import GHC.IO.FD
+import GHC.IO.Handle.FD
+import GHC.Ptr
+import GHC.Real
+import GHC.Windows
+
+#endif
+
+import Data.Functor
+import GHC.Base
+import GHC.Exception
+import GHC.IO.Handle.Types
+import GHC.Show
+
+-- | Exception thrown by 'hLock' on non-Windows platforms that don't support
+-- 'flock'.
+data FileLockingNotSupported = FileLockingNotSupported
+  deriving 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 = 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
+
+----------------------------------------
+
+#if 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 -> 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
+
+#elif 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
+    -- leaving the highest bit set to 0.
+    fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0x7fffffff 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
+
+-- | No-op implementation.
+lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
+lockImpl _ _ _ _ = throwIO FileLockingNotSupported
+
+#endif