Commit 78b70e63 authored by Ben Gamari's avatar Ben Gamari 🐢 Committed by Marge Bot

base: Split up file locking implementation

This makes the CPP significantly easier to follow.
parent 7d3a15c7
Pipeline #11932 passed with stages
in 1037 minutes and 5 seconds
{-# 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
----------------------------------------
{-# 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
{-# 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
{-# LANGUAGE CPP #-}
{-# LANGUAGE InterruptibleFFI #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}
module GHC.IO.Handle.Lock (
FileLockingNotSupported(..)
, LockMode(..)
, hLock
, hTryLock
, hUnlock
) where
-- | File locking via the Linux open-fd locking mechanism.
module GHC.IO.Handle.Lock.LinuxOFD where
#include "HsBaseConfig.h"
#if HAVE_OFD_LOCKING
#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.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.Base
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.IO.Handle.Lock.Common
import GHC.IO.Handle.Types (Handle)
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
----------------------------------------
import System.Posix.Types (COff, CPid)
#if HAVE_OFD_LOCKING
-- Linux open file descriptor locking.
--
-- We prefer this over BSD locking (e.g. flock) since the latter appears to
......@@ -194,91 +100,4 @@ unlockImpl h = do
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
{-# 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
{-# 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
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment