diff --git a/hackage-security/hackage-security.cabal b/hackage-security/hackage-security.cabal index 802c244d..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, @@ -103,7 +104,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, @@ -123,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 f5101acf..31bb8533 100644 --- a/hackage-security/src/Hackage/Security/Util/IO.hs +++ b/hackage-security/src/Hackage/Security/Util/IO.hs @@ -7,13 +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 qualified System.FileLock as FL import Hackage.Security.Util.Path +import Hackage.Security.Util.FileLock (hTryLock, LockMode(ExclusiveLock), FileLockingNotSupported) {------------------------------------------------------------------------------- Miscelleneous @@ -35,16 +36,31 @@ handleDoesNotExist act = -- -- This will use OS-specific file locking primitives, and throw an -- exception if the lock is already present. +-- +-- May fallback to locking via creating a directory. 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 . const where + lockDir :: Path Absolute + lockDir = dir fragment "hackage-security-lock-dir" + lock :: FilePath lock = toFilePath $ dir fragment "hackage-security-lock" + takeLock = do + h <- openFile lock ReadWriteMode + handle takeDirLock $ do + gotlock <- hTryLock h ExclusiveLock + unless gotlock $ + fail $ "hTryLock: lock already exists: " ++ lock + return (Just h) + + takeDirLock :: FileLockingNotSupported -> IO (Maybe Handle) + takeDirLock _ = createDirectory lockDir >> return Nothing + + releaseLock (Just h) = hClose h + releaseLock Nothing = removeDirectory lockDir + {------------------------------------------------------------------------------- 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