From a5cfcd8fc8eba39bae510ad9a2af41d57f90dbb8 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 15 Feb 2018 01:17:05 +0200 Subject: [PATCH 1/3] Revert "Use file instead of dir locking #187 (#203)" This reverts commit d91afd37deb0eb8494400be90072edf0dc493fc4. --- hackage-security/hackage-security.cabal | 1 - .../src/Hackage/Security/Util/IO.hs | 24 ++++++++++--------- stack.yaml | 1 - 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/hackage-security/hackage-security.cabal b/hackage-security/hackage-security.cabal index 802c244d..03efc8da 100644 --- a/hackage-security/hackage-security.cabal +++ b/hackage-security/hackage-security.cabal @@ -103,7 +103,6 @@ library Cabal >= 1.14 && < 2.2, containers >= 0.4 && < 0.6, ed25519 >= 0.0 && < 0.1, - filelock >= 0.1.1 && < 0.2, filepath >= 1.2 && < 1.5, mtl >= 2.2 && < 2.3, parsec >= 3.1 && < 3.2, diff --git a/hackage-security/src/Hackage/Security/Util/IO.hs b/hackage-security/src/Hackage/Security/Util/IO.hs index f5101acf..1601b7b4 100644 --- a/hackage-security/src/Hackage/Security/Util/IO.hs +++ b/hackage-security/src/Hackage/Security/Util/IO.hs @@ -11,7 +11,6 @@ import Control.Exception import Data.Time import System.IO hiding (openTempFile, withFile) import System.IO.Error -import qualified System.FileLock as FL import Hackage.Security.Util.Path @@ -31,19 +30,22 @@ handleDoesNotExist act = then return Nothing else throwIO e --- | Attempt to create a filesystem lock in the specified directory. +-- | Attempt to create a filesystem lock in the specified directory -- --- This will use OS-specific file locking primitives, and throw an --- exception if the lock is already present. +-- Given a file @/path/to@, we do this by attempting to create the directory +-- @//path/to/hackage-security-lock@, and deleting the directory again +-- afterwards. Creating a directory that already exists will throw an exception +-- on most OSs (certainly Linux, OSX and Windows) and is a reasonably common way +-- to implement a lock file. withDirLock :: Path Absolute -> IO a -> IO a -withDirLock dir act = do - res <- FL.withTryFileLock lock FL.Exclusive (const act) - case res of - Just a -> return a - Nothing -> error $ "withFileLock: lock already exists: " ++ lock +withDirLock dir = bracket_ takeLock releaseLock where - lock :: FilePath - lock = toFilePath $ dir fragment "hackage-security-lock" + lock :: Path Absolute + lock = dir fragment "hackage-security-lock" + + takeLock, releaseLock :: IO () + takeLock = createDirectory lock + releaseLock = removeDirectory lock {------------------------------------------------------------------------------- Debugging diff --git a/stack.yaml b/stack.yaml index 3263628a..53cb73e2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -10,4 +10,3 @@ packages: - precompute-fileinfo extra-deps: - http-client-0.5.5 -- filelock-0.1.1.2 From 2a1a6cc33331179ac6e131ee6783978dbcc8882c Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 15 Feb 2018 01:18:17 +0200 Subject: [PATCH 2/3] Use GHC.IO.Handle.Lock shim for "dirLock" Does d91afd37deb0eb8494400be90072edf0dc493fc4 in better way See also https://github.com/haskell/cabal/issues/5072 for discussion about locking. TL;DR if we want to use fcntl, we have to make proper implementation and audit it. The directory creation fallback will be used on at least Solaris and AIX --- hackage-security/hackage-security.cabal | 4 +- .../src/Hackage/Security/Util/FileLock.hsc | 204 ++++++++++++++++++ .../src/Hackage/Security/Util/IO.hs | 41 +++- 3 files changed, 243 insertions(+), 6 deletions(-) create mode 100644 hackage-security/src/Hackage/Security/Util/FileLock.hsc diff --git a/hackage-security/hackage-security.cabal b/hackage-security/hackage-security.cabal index 03efc8da..ff5d0e2d 100644 --- a/hackage-security/hackage-security.cabal +++ b/hackage-security/hackage-security.cabal @@ -90,10 +90,11 @@ library Hackage.Security.TUF.Targets Hackage.Security.TUF.Timestamp Hackage.Security.Util.Base64 + Hackage.Security.Util.Exit + Hackage.Security.Util.FileLock Hackage.Security.Util.JSON Hackage.Security.Util.Stack Hackage.Security.Util.TypedEmbedded - Hackage.Security.Util.Exit Prelude -- We support ghc 7.4 (bundled with Cabal 1.14) and up build-depends: base >= 4.5 && < 5, @@ -122,6 +123,7 @@ library old-time >= 1 && < 1.2 else build-depends: directory >= 1.2 && < 1.4 + build-tool-depends: hsc2hs:hsc2hs >= 0.67 && <0.69 hs-source-dirs: src default-language: Haskell2010 default-extensions: DefaultSignatures diff --git a/hackage-security/src/Hackage/Security/Util/FileLock.hsc b/hackage-security/src/Hackage/Security/Util/FileLock.hsc new file mode 100644 index 00000000..7e4a7d2c --- /dev/null +++ b/hackage-security/src/Hackage/Security/Util/FileLock.hsc @@ -0,0 +1,204 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE InterruptibleFFI #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This compat module can be removed once base-4.10 (ghc-8.2) is the minimum +-- required version. Though note that the locking functionality is not in +-- public modules in base-4.10, just in the "GHC.IO.Handle.Lock" module. +-- +-- Copied from @cabal-install@ codebase "Distribution.Client.Compat.FileLock". +module Hackage.Security.Util.FileLock ( + FileLockingNotSupported(..) + , LockMode(..) + , hLock + , hTryLock + ) where + +#if MIN_VERSION_base(4,10,0) + +import GHC.IO.Handle.Lock + +#else + +-- The remainder of this file is a modified copy +-- of GHC.IO.Handle.Lock from ghc-8.2.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 +-- lack of HAVE_FLOCK with @defined(solaris2_HOST_OS) || defined(aix_HOST_OS)@ +-- instead since those are known major Unix platforms lacking @flock()@ or +-- having broken one. + +import Control.Exception (Exception) +import Data.Typeable + +#if defined(solaris2_HOST_OS) || defined(aix_HOST_OS) + +import Control.Exception (throwIO) +import System.IO (Handle) + +#else + +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 + +#if 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 + +import Foreign.Marshal.Alloc +import Foreign.Marshal.Utils +import Foreign.Ptr +import GHC.Windows + +#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */ + +#include + +#endif /* !defined(mingw32_HOST_OS) */ + +#endif /* !(defined(solaris2_HOST_OS) || defined(aix_HOST_OS)) */ + + +-- | Exception thrown by 'hLock' on non-Windows platforms that don't support +-- 'flock'. +data FileLockingNotSupported = FileLockingNotSupported + deriving (Typeable, 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 = lockImpl h "hLock" mode True >> return () + +-- | Non-blocking version of 'hLock'. +-- +-- @since 4.10.0.0 +hTryLock :: Handle -> LockMode -> IO Bool +hTryLock h mode = lockImpl h "hTryLock" mode False + +---------------------------------------- + +#if defined(solaris2_HOST_OS) || defined(aix_HOST_OS) + +-- | No-op implementation. +lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool +lockImpl _ _ _ _ = throwIO FileLockingNotSupported + +#else /* !(defined(solaris2_HOST_OS) || defined(aix_HOST_OS)) */ + +#if 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 + -- trying 2^32-1. + fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0x0 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 /* !defined(mingw32_HOST_OS), so assume unix with 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 + +#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 + +#endif /* defined(solaris2_HOST_OS) || defined(aix_HOST_OS) */ + +#endif /* MIN_VERSION_base */ diff --git a/hackage-security/src/Hackage/Security/Util/IO.hs b/hackage-security/src/Hackage/Security/Util/IO.hs index 1601b7b4..3e9f8d5c 100644 --- a/hackage-security/src/Hackage/Security/Util/IO.hs +++ b/hackage-security/src/Hackage/Security/Util/IO.hs @@ -7,12 +7,14 @@ module Hackage.Security.Util.IO ( , timedIO ) where +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 (hTryLock, LockMode(ExclusiveLock), FileLockingNotSupported) {------------------------------------------------------------------------------- Miscelleneous @@ -30,22 +32,51 @@ handleDoesNotExist act = then return Nothing else throwIO e --- | Attempt to create a filesystem lock in the specified directory +-- | Attempt to create a filesystem lock in the specified directory. -- +-- This will use OS-specific file locking primitives: "GHC.IO.Handle.Lock" with +-- @base-4.10" and later or a shim for @base@ versions. +-- +-- Throws an exception if the lock is already present. +-- +-- May fallback to locking via creating a directory: -- Given a file @/path/to@, we do this by attempting to create the directory -- @//path/to/hackage-security-lock@, and deleting the directory again -- afterwards. Creating a directory that already exists will throw an exception -- on most OSs (certainly Linux, OSX and Windows) and is a reasonably common way -- to implement a lock file. withDirLock :: Path Absolute -> IO a -> IO a -withDirLock dir = bracket_ takeLock releaseLock +withDirLock dir = bracket takeLock releaseLock . const where lock :: Path Absolute lock = dir fragment "hackage-security-lock" - takeLock, releaseLock :: IO () - takeLock = createDirectory lock - releaseLock = removeDirectory lock + lock' :: FilePath + lock' = toFilePath lock + + takeLock = do + h <- openFile lock' ReadWriteMode + handle (takeDirLock h) $ do + gotlock <- hTryLock h ExclusiveLock + unless gotlock $ + fail $ "hTryLock: lock already exists: " ++ lock' + return (Just h) + + takeDirLock :: Handle -> FileLockingNotSupported -> IO (Maybe Handle) + takeDirLock h _ = do + -- We fallback to directory locking + -- so we need to cleanup lock file first: close and remove + hClose h + handle onIOError (removeFile lock) + createDirectory lock + return Nothing + + onIOError :: IOError -> IO () + onIOError _ = hPutStrLn stderr + "withDirLock: cannot remove lock file before directory lock fallback" + + releaseLock (Just h) = hClose h + releaseLock Nothing = removeDirectory lock {------------------------------------------------------------------------------- Debugging From a457de564b3a58758c763e1f1274fb1a64f3a1d1 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 15 Feb 2018 02:08:51 +0200 Subject: [PATCH 3/3] Remove LambdaCase and MultiWayIf --- .../src/Hackage/Security/Util/FileLock.hsc | 22 +++++++++---------- 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/hackage-security/src/Hackage/Security/Util/FileLock.hsc b/hackage-security/src/Hackage/Security/Util/FileLock.hsc index 7e4a7d2c..65bee013 100644 --- a/hackage-security/src/Hackage/Security/Util/FileLock.hsc +++ b/hackage-security/src/Hackage/Security/Util/FileLock.hsc @@ -1,7 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE InterruptibleFFI #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE DeriveDataTypeable #-} -- | This compat module can be removed once base-4.10 (ghc-8.2) is the minimum @@ -142,12 +140,12 @@ lockImpl h ctx mode block = do -- 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 >>= \case + fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0x0 ovrlpd >>= \b -> case b of 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 + 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 = #{size OVERLAPPED} @@ -169,12 +167,12 @@ 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 + fix $ \retry -> c_flock fd flags >>= \n -> case n of 0 -> return True - _ -> getErrno >>= \errno -> if - | not block && errno == eWOULDBLOCK -> return False - | errno == eINTR -> retry - | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing + _ -> 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}