summaryrefslogtreecommitdiff
path: root/libraries/base
diff options
context:
space:
mode:
Diffstat (limited to 'libraries/base')
-rw-r--r--libraries/base/GHC/IO/Handle/Lock.hs68
-rw-r--r--libraries/base/GHC/IO/Handle/Lock.hsc284
-rw-r--r--libraries/base/GHC/IO/Handle/Lock/Common.hs21
-rw-r--r--libraries/base/GHC/IO/Handle/Lock/Flock.hsc53
-rw-r--r--libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc103
-rw-r--r--libraries/base/GHC/IO/Handle/Lock/NoOp.hs16
-rw-r--r--libraries/base/GHC/IO/Handle/Lock/Windows.hsc86
-rw-r--r--libraries/base/base.cabal5
8 files changed, 352 insertions, 284 deletions
diff --git a/libraries/base/GHC/IO/Handle/Lock.hs b/libraries/base/GHC/IO/Handle/Lock.hs
new file mode 100644
index 0000000000..09df4a24ae
--- /dev/null
+++ b/libraries/base/GHC/IO/Handle/Lock.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE InterruptibleFFI #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.IO.Handle.Lock (
+ FileLockingNotSupported(..)
+ , LockMode(..)
+ , hLock
+ , hTryLock
+ , hUnlock
+ ) where
+
+
+#include "HsBaseConfig.h"
+
+import Data.Functor (void)
+import GHC.Base
+import GHC.IO.Handle.Lock.Common (LockMode(..), FileLockingNotSupported(..))
+import GHC.IO.Handle.Types (Handle)
+
+#if defined(mingw32_HOST_OS)
+import GHC.IO.Handle.Lock.Windows
+#elif HAVE_OFD_LOCKING
+import GHC.IO.Handle.Lock.LinuxOFD
+#elif HAVE_FLOCK
+import GHC.IO.Handle.Lock.Flock
+#else
+import GHC.IO.Handle.Lock.NoOp
+#endif
+
+-- | 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
+
+-- | Release a lock taken with 'hLock' or 'hTryLock'.
+--
+-- @since 4.11.0.0
+hUnlock :: Handle -> IO ()
+hUnlock = unlockImpl
+
+----------------------------------------
+
diff --git a/libraries/base/GHC/IO/Handle/Lock.hsc b/libraries/base/GHC/IO/Handle/Lock.hsc
deleted file mode 100644
index d75fbcf5a6..0000000000
--- a/libraries/base/GHC/IO/Handle/Lock.hsc
+++ /dev/null
@@ -1,284 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE InterruptibleFFI #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-module GHC.IO.Handle.Lock (
- FileLockingNotSupported(..)
- , LockMode(..)
- , hLock
- , hTryLock
- , hUnlock
- ) where
-
-#include "HsBaseConfig.h"
-
-#if HAVE_OFD_LOCKING
-
-#include <sys/unistd.h>
-#include <sys/fcntl.h>
-
-import Data.Function
-import Foreign.C.Error
-import Foreign.C.Types
-import Foreign.Marshal.Utils
-import Foreign.Storable
-import GHC.Ptr
-import GHC.IO.Exception
-import GHC.IO.FD
-import GHC.IO.Handle.FD
-import System.Posix.Types (COff, CPid)
-
-#elif 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.FD
-import GHC.IO.Handle.FD
-import GHC.Ptr
-import GHC.Windows
-
-#else
-
-import GHC.IO (throwIO)
-
-#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 -- ^ @since 4.10.0.0
-
--- ^ @since 4.10.0.0
-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
-
--- | Release a lock taken with 'hLock' or 'hTryLock'.
---
--- @since 4.11.0.0
-hUnlock :: Handle -> IO ()
-hUnlock = unlockImpl
-
-----------------------------------------
-
-#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 FLock -> 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 struct flock}
- alignment _ = #{alignment struct flock}
- poke ptr x = do
- fillBytes ptr 0 (sizeOf x)
- #{poke struct flock, l_type} ptr (l_type x)
- #{poke struct flock, l_whence} ptr (l_whence x)
- #{poke struct flock, l_start} ptr (l_start x)
- #{poke struct flock, l_len} ptr (l_len x)
- #{poke struct flock, l_pid} ptr (l_pid x)
- peek ptr = do
- FLock <$> #{peek struct flock, l_type} ptr
- <*> #{peek struct flock, l_whence} ptr
- <*> #{peek struct flock, l_start} ptr
- <*> #{peek struct flock, l_len} ptr
- <*> #{peek struct flock, l_pid} ptr
-
-lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
-lockImpl h ctx mode block = do
- FD{fdFD = fd} <- handleToFd h
- with flock $ \flock_ptr -> fix $ \retry -> do
- ret <- c_fcntl fd mode' flock_ptr
- case ret of
- 0 -> return True
- _ -> getErrno >>= \errno -> if
- | 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
- , l_pid = 0
- }
- mode'
- | block = #{const F_OFD_SETLKW}
- | otherwise = #{const F_OFD_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
- , l_pid = 0
- }
- throwErrnoIfMinus1_ "hUnlock"
- $ with flock $ c_fcntl fd #{const F_OFD_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 -> c_flock fd flags >>= \case
- 0 -> return True
- _ -> getErrno >>= \errno -> if
- | 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}
-
-unlockImpl :: Handle -> IO ()
-unlockImpl h = do
- FD{fdFD = fd} <- handleToFd h
- throwErrnoIfMinus1_ "flock" $ c_flock fd #{const LOCK_UN}
-
-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 0 sizeof_OVERLAPPED
- 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", hence we pass maximum value as the number of bytes to
- -- lock.
- fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0xffffffff 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}
-
-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
- c_UnlockFileEx wh 0 0xffffffff 0xffffffff ovrlpd >>= \case
- 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
-
--- 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
-
--- 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
-
-#else
-
--- | No-op implementation.
-lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
-lockImpl _ _ _ _ = throwIO FileLockingNotSupported
-
--- | No-op implementation.
-unlockImpl :: Handle -> IO ()
-unlockImpl _ = throwIO FileLockingNotSupported
-
-#endif
diff --git a/libraries/base/GHC/IO/Handle/Lock/Common.hs b/libraries/base/GHC/IO/Handle/Lock/Common.hs
new file mode 100644
index 0000000000..b85e0916ab
--- /dev/null
+++ b/libraries/base/GHC/IO/Handle/Lock/Common.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Things common to all file locking implementations.
+module GHC.IO.Handle.Lock.Common
+ ( FileLockingNotSupported(..)
+ , LockMode(..)
+ ) where
+
+import GHC.Exception
+import GHC.Show
+
+-- | Exception thrown by 'hLock' on non-Windows platforms that don't support
+-- 'flock'.
+data FileLockingNotSupported = FileLockingNotSupported
+ deriving Show -- ^ @since 4.10.0.0
+
+-- ^ @since 4.10.0.0
+instance Exception FileLockingNotSupported
+
+-- | Indicates a mode in which a file should be locked.
+data LockMode = SharedLock | ExclusiveLock
diff --git a/libraries/base/GHC/IO/Handle/Lock/Flock.hsc b/libraries/base/GHC/IO/Handle/Lock/Flock.hsc
new file mode 100644
index 0000000000..c7e6704ebf
--- /dev/null
+++ b/libraries/base/GHC/IO/Handle/Lock/Flock.hsc
@@ -0,0 +1,53 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE InterruptibleFFI #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | File locking via POSIX @flock@.
+module GHC.IO.Handle.Lock.Flock where
+
+#include "HsBaseConfig.h"
+
+#if !HAVE_FLOCK
+import GHC.Base () -- Make implicit dependency known to build system
+#else
+
+#include <sys/file.h>
+
+import Data.Bits
+import Data.Function
+import Foreign.C.Error
+import Foreign.C.Types
+import GHC.Base
+import GHC.IO.Exception
+import GHC.IO.FD
+import GHC.IO.Handle.FD
+import GHC.IO.Handle.Lock.Common
+import GHC.IO.Handle.Types (Handle)
+
+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 == 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}
+
+unlockImpl :: Handle -> IO ()
+unlockImpl h = do
+ FD{fdFD = fd} <- handleToFd h
+ throwErrnoIfMinus1_ "flock" $ c_flock fd #{const LOCK_UN}
+
+foreign import ccall interruptible "flock"
+ c_flock :: CInt -> CInt -> IO CInt
+
+#endif
diff --git a/libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc b/libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc
new file mode 100644
index 0000000000..1046fa9351
--- /dev/null
+++ b/libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc
@@ -0,0 +1,103 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE InterruptibleFFI #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | File locking via the Linux open-fd locking mechanism.
+module GHC.IO.Handle.Lock.LinuxOFD where
+
+#include "HsBaseConfig.h"
+
+#if !HAVE_OFD_LOCKING
+import GHC.Base () -- Make implicit dependency known to build system
+#else
+
+#include <sys/unistd.h>
+#include <sys/fcntl.h>
+
+import Data.Function
+import Data.Functor
+import Foreign.C.Error
+import Foreign.C.Types
+import Foreign.Marshal.Utils
+import Foreign.Storable
+import GHC.Base
+import GHC.IO.Exception
+import GHC.IO.FD
+import GHC.IO.Handle.FD
+import GHC.IO.Handle.Lock.Common
+import GHC.IO.Handle.Types (Handle)
+import GHC.Ptr
+import System.Posix.Types (COff, CPid)
+
+-- 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 FLock -> 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 struct flock}
+ alignment _ = #{alignment struct flock}
+ poke ptr x = do
+ fillBytes ptr 0 (sizeOf x)
+ #{poke struct flock, l_type} ptr (l_type x)
+ #{poke struct flock, l_whence} ptr (l_whence x)
+ #{poke struct flock, l_start} ptr (l_start x)
+ #{poke struct flock, l_len} ptr (l_len x)
+ #{poke struct flock, l_pid} ptr (l_pid x)
+ peek ptr = do
+ FLock <$> #{peek struct flock, l_type} ptr
+ <*> #{peek struct flock, l_whence} ptr
+ <*> #{peek struct flock, l_start} ptr
+ <*> #{peek struct flock, l_len} ptr
+ <*> #{peek struct flock, l_pid} ptr
+
+lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
+lockImpl h ctx mode block = do
+ FD{fdFD = fd} <- handleToFd h
+ with flock $ \flock_ptr -> fix $ \retry -> do
+ ret <- c_fcntl fd mode' flock_ptr
+ case ret of
+ 0 -> return True
+ _ -> getErrno >>= \errno -> if
+ | 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
+ , l_pid = 0
+ }
+ mode'
+ | block = #{const F_OFD_SETLKW}
+ | otherwise = #{const F_OFD_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
+ , l_pid = 0
+ }
+ throwErrnoIfMinus1_ "hUnlock"
+ $ with flock $ c_fcntl fd #{const F_OFD_SETLK}
+
+#endif
diff --git a/libraries/base/GHC/IO/Handle/Lock/NoOp.hs b/libraries/base/GHC/IO/Handle/Lock/NoOp.hs
new file mode 100644
index 0000000000..b910c6811a
--- /dev/null
+++ b/libraries/base/GHC/IO/Handle/Lock/NoOp.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.IO.Handle.Lock.NoOp where
+
+import GHC.Base
+import GHC.IO (throwIO)
+import GHC.IO.Handle.Lock.Common
+import GHC.IO.Handle.Types (Handle)
+
+-- | No-op implementation.
+lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
+lockImpl _ _ _ _ = throwIO FileLockingNotSupported
+
+-- | No-op implementation.
+unlockImpl :: Handle -> IO ()
+unlockImpl _ = throwIO FileLockingNotSupported
diff --git a/libraries/base/GHC/IO/Handle/Lock/Windows.hsc b/libraries/base/GHC/IO/Handle/Lock/Windows.hsc
new file mode 100644
index 0000000000..45c060f901
--- /dev/null
+++ b/libraries/base/GHC/IO/Handle/Lock/Windows.hsc
@@ -0,0 +1,86 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE InterruptibleFFI #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | File locking for Windows.
+module GHC.IO.Handle.Lock.Windows where
+
+#include "HsBaseConfig.h"
+
+#if !defined(mingw32_HOST_OS)
+import GHC.Base () -- Make implicit dependency known to build system
+#else
+
+#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.FD
+import GHC.IO.Handle.FD
+import GHC.Ptr
+import GHC.Windows
+
+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 0 sizeof_OVERLAPPED
+ 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", hence we pass maximum value as the number of bytes to
+ -- lock.
+ fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0xffffffff 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}
+
+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
+ c_UnlockFileEx wh 0 0xffffffff 0xffffffff ovrlpd >>= \case
+ 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
+
+-- 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
+
+-- 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
+
+#endif
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index 8819757f20..b978e3fdbf 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -328,6 +328,11 @@ Library
Data.Semigroup.Internal
Data.Typeable.Internal
Foreign.ForeignPtr.Imp
+ GHC.IO.Handle.Lock.Common
+ GHC.IO.Handle.Lock.Flock
+ GHC.IO.Handle.Lock.LinuxOFD
+ GHC.IO.Handle.Lock.NoOp
+ GHC.IO.Handle.Lock.Windows
GHC.StaticPtr.Internal
System.Environment.ExecutablePath
System.CPUTime.Utils