diff --git a/hackage-security/src/Hackage/Security/Util/FileLock.hsc b/hackage-security/src/Hackage/Security/Util/FileLock.hsc index 1de2bcb5..d46fe3ac 100644 --- a/hackage-security/src/Hackage/Security/Util/FileLock.hsc +++ b/hackage-security/src/Hackage/Security/Util/FileLock.hsc @@ -12,16 +12,31 @@ module Hackage.Security.Util.FileLock ( , LockMode(..) , hLock , hTryLock + , hUnlock ) where -#if MIN_VERSION_base(4,10,0) +#if MIN_VERSION_base(4,11,0) import GHC.IO.Handle.Lock +#elif MIN_VERSION_base(4,10,0) + +import GHC.IO.Handle.Lock + +-- N.B. base-4.10 (GHC 8.2) didn't have hUnlock. For the time being we simply +-- define this to be a no-op since we generally close the lock handle anyways. +-- +-- However, do note that on Windows it can take longer for an outstanding +-- lock to be released after its handle is closed than if the lock were +-- explicitly released. + +hUnlock :: Handle -> IO () +hUnlock hdl = return () + #else -- The remainder of this file is a modified copy --- of GHC.IO.Handle.Lock from ghc-8.2.x +-- of GHC.IO.Handle.Lock from ghc-8.9.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 @@ -29,28 +44,20 @@ import GHC.IO.Handle.Lock -- instead since those are known major Unix platforms lacking @flock()@ or -- having broken one. -import Control.Exception (Exception) -import Data.Typeable +-- We avoid using #define as it breaks older hsc2hs #if defined(solaris2_HOST_OS) || defined(aix_HOST_OS) -import Control.Exception (throwIO) -import System.IO (Handle) - -#else +#include 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 +import GHC.IO.Handle.FD -#if defined(mingw32_HOST_OS) +#elif defined(mingw32_HOST_OS) #if defined(i386_HOST_ARCH) ## define WINDOWS_CCONV stdcall @@ -62,19 +69,29 @@ import GHC.IO.Exception #include +import Data.Bits +import Data.Function +import Foreign.C.Error +import Foreign.C.Types import Foreign.Marshal.Alloc import Foreign.Marshal.Utils -import Foreign.Ptr +import GHC.IO.FD +import GHC.IO.Handle.FD +import GHC.Ptr import GHC.Windows -#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */ - -#include +#else -#endif /* !defined(mingw32_HOST_OS) */ +import GHC.IO (throwIO) -#endif /* !(defined(solaris2_HOST_OS) || defined(aix_HOST_OS)) */ +#endif /* HAVE_FLOCK */ +import Data.Functor +import GHC.Base +import GHC.Exception +import GHC.IO.Handle.Types +import GHC.Show +import Data.Typeable (Typeable) -- | Exception thrown by 'hLock' on non-Windows platforms that don't support -- 'flock'. @@ -83,7 +100,6 @@ data FileLockingNotSupported = FileLockingNotSupported instance Exception FileLockingNotSupported - -- | Indicates a mode in which a file should be locked. data LockMode = SharedLock | ExclusiveLock @@ -107,7 +123,7 @@ data LockMode = SharedLock | ExclusiveLock -- -- @since 4.10.0.0 hLock :: Handle -> LockMode -> IO () -hLock h mode = lockImpl h "hLock" mode True >> return () +hLock h mode = void $ lockImpl h "hLock" mode True -- | Non-blocking version of 'hLock'. -- @@ -115,17 +131,112 @@ hLock h mode = lockImpl h "hLock" mode True >> return () hTryLock :: Handle -> LockMode -> IO Bool hTryLock h mode = lockImpl h "hTryLock" mode False +-- | Release a lock taken with 'hLock' or 'hTryLock'. +hUnlock :: Handle -> IO () +hUnlock = unlockImpl + ---------------------------------------- -#if defined(solaris2_HOST_OS) || defined(aix_HOST_OS) +#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 () -> 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 flock} + alignment _ = #{alignment flock} + poke ptr x = do + fillBytes ptr 0 (sizeOf x) + #{poke flock, l_type} ptr (l_type x) + #{poke flock, l_whence} ptr (l_whence x) + #{poke flock, l_start} ptr (l_start x) + #{poke flock, l_len} ptr (l_len x) + #{poke flock, l_pid} ptr (l_pid x) + peek ptr = do + FLock <$> #{peek flock, l_type} ptr + <*> #{peek flock, l_whence} ptr + <*> #{peek flock, l_start} ptr + <*> #{peek flock, l_len} ptr + <*> #{peek flock, l_pid} ptr --- | No-op implementation. lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool -lockImpl _ _ _ _ = throwIO FileLockingNotSupported +lockImpl h ctx mode block = do + FD{fdFD = fd} <- handleToFd h + with flock $ \flock_ptr -> fix $ \retry -> do + ret <- with flock $ fcntl fd mode flock_ptr + case ret of + 0 -> return True + _ -> getErrno >>= \errno -> + case () of + _ | 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 + } + mode + | block = #{const F_SETLKW} + | otherwise = #{const F_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 + } + throwErrnoIfMinus1_ "hUnlock" + $ with flock $ c_fcntl fd #{const F_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 -> do + ret <- c_flock fd flags + case ret of + 0 -> return True + _ -> getErrno >>= \errno -> + case () of + _ | 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} -#else /* !(defined(solaris2_HOST_OS) || defined(aix_HOST_OS)) */ +unlockImpl :: Handle -> IO () +unlockImpl h = do + FD{fdFD = fd} <- handleToFd h + throwErrnoIfMinus1_ "flock" $ c_flock fd #{const LOCK_UN} -#if defined(mingw32_HOST_OS) +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 @@ -137,23 +248,37 @@ lockImpl h ctx mode block = do -- 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 >>= \b -> case b of - True -> return True - False -> getLastError >>= \err -> case () of - () | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False - | err == #{const ERROR_OPERATION_ABORTED} -> retry - | otherwise -> failWith ctx err + -- not an error", hence we pass maximum value as the number of bytes to + -- lock. + fix $ \retry -> do + ret <- c_LockFileEx wh flags 0 0xffffffff 0xffffffff ovrlpd + case ret of + True -> return True + False -> getLastError >>= \err -> + case () of + _ | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False + | err == #{const ERROR_OPERATION_ABORTED} -> retry + | otherwise -> failWith ctx err where - sizeof_OVERLAPPED :: Int 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 + ret <- c_UnlockFileEx wh 0 0xffffffff 0xffffffff ovrlpd + case ret of + 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 @@ -162,42 +287,20 @@ foreign import ccall unsafe "_get_osfhandle" 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() */ +-- 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 -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 >>= \n -> case n of - 0 -> return True - _ -> getErrno >>= \errno -> case () of - () | 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} +#else -foreign import ccall interruptible "flock" - c_flock :: CInt -> CInt -> IO CInt +-- | No-op implementation. +lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool +lockImpl _ _ _ _ = throwIO FileLockingNotSupported -#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 +-- | No-op implementation. +unlockImpl :: Handle -> IO () +unlockImpl _ = throwIO FileLockingNotSupported -#endif /* defined(solaris2_HOST_OS) || defined(aix_HOST_OS) */ +#endif -#endif /* MIN_VERSION_base */ +#endif /* MIN_VERSION_base(4,10,0) */ diff --git a/hackage-security/src/Hackage/Security/Util/IO.hs b/hackage-security/src/Hackage/Security/Util/IO.hs index 9c8fea5a..215a2f7c 100644 --- a/hackage-security/src/Hackage/Security/Util/IO.hs +++ b/hackage-security/src/Hackage/Security/Util/IO.hs @@ -8,14 +8,13 @@ module Hackage.Security.Util.IO ( ) where import Control.Concurrent (threadDelay) -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 (hLock, LockMode(ExclusiveLock), FileLockingNotSupported) +import Hackage.Security.Util.FileLock (hLock, LockMode(ExclusiveLock), FileLockingNotSupported, hUnlock) {------------------------------------------------------------------------------- Miscelleneous @@ -85,7 +84,7 @@ withDirLock dir = bracket takeLock releaseLock . const me = "Hackage.Security.Util.IO.withDirLock: " - releaseLock (Just h) = hClose h + releaseLock (Just h) = hUnlock h >> hClose h releaseLock Nothing = removeDirectory lock {-------------------------------------------------------------------------------