diff options
Diffstat (limited to 'libraries/base')
| -rw-r--r-- | libraries/base/GHC/IO/Handle/Lock.hs | 68 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/Handle/Lock.hsc | 284 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/Handle/Lock/Common.hs | 21 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/Handle/Lock/Flock.hsc | 53 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc | 103 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/Handle/Lock/NoOp.hs | 16 | ||||
| -rw-r--r-- | libraries/base/GHC/IO/Handle/Lock/Windows.hsc | 86 | ||||
| -rw-r--r-- | libraries/base/base.cabal | 5 |
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 |