Hello community, here is the log from the commit of package ghc-hackage-security for openSUSE:Factory checked in at 2018-05-30 12:08:12 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-hackage-security (Old) and /work/SRC/openSUSE:Factory/.ghc-hackage-security.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-hackage-security" Wed May 30 12:08:12 2018 rev:8 rq:607805 version:0.5.3.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-hackage-security/ghc-hackage-security.changes 2017-09-15 21:46:35.017574876 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-hackage-security.new/ghc-hackage-security.changes 2018-05-30 12:25:48.097347754 +0200 @@ -1,0 +2,10 @@ +Mon May 14 17:02:11 UTC 2018 - psim...@suse.com + +- Update hackage-security to version 0.5.3.0. + * Use `flock(2)`-based locking where available + (compat-shim taken from `cabal-install`'s code-base) (#207) + * Improve handling of async exceptions (#187) + * Detect & recover from local corruption of uncompressed index tarball (#196) + * Support `base-4.11` + +------------------------------------------------------------------- Old: ---- hackage-security-0.5.2.2.tar.gz hackage-security.cabal New: ---- hackage-security-0.5.3.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-hackage-security.spec ++++++ --- /var/tmp/diff_new_pack.JvXCtt/_old 2018-05-30 12:25:48.981318358 +0200 +++ /var/tmp/diff_new_pack.JvXCtt/_new 2018-05-30 12:25:48.985318225 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-hackage-security # -# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2018 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,14 +19,13 @@ %global pkg_name hackage-security %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.5.2.2 +Version: 0.5.3.0 Release: 0 Summary: Hackage security library License: BSD-3-Clause Group: Development/Libraries/Haskell URL: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz -Source1: https://hackage.haskell.org/package/%{pkg_name}-%{version}/revision/4.cabal#/%{pkg_name}.cabal BuildRequires: ghc-Cabal-devel BuildRequires: ghc-base16-bytestring-devel BuildRequires: ghc-base64-bytestring-devel @@ -48,7 +47,6 @@ BuildRequires: ghc-transformers-devel BuildRequires: ghc-zlib-devel %if %{with tests} -BuildRequires: ghc-HUnit-devel BuildRequires: ghc-QuickCheck-devel BuildRequires: ghc-tasty-devel BuildRequires: ghc-tasty-hunit-devel @@ -87,7 +85,6 @@ %prep %setup -q -n %{pkg_name}-%{version} -cp -p %{SOURCE1} %{pkg_name}.cabal %build %ghc_lib_build @@ -105,7 +102,7 @@ %ghc_pkg_recache %files -f %{name}.files -%doc LICENSE +%license LICENSE %files devel -f %{name}-devel.files %doc ChangeLog.md ++++++ hackage-security-0.5.2.2.tar.gz -> hackage-security-0.5.3.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.2.2/ChangeLog.md new/hackage-security-0.5.3.0/ChangeLog.md --- old/hackage-security-0.5.2.2/ChangeLog.md 2016-08-29 00:57:40.000000000 +0200 +++ new/hackage-security-0.5.3.0/ChangeLog.md 2018-03-26 01:39:07.000000000 +0200 @@ -1,3 +1,12 @@ +0.5.3.0 +------- + +* Use `flock(2)`-based locking where available + (compat-shim taken from `cabal-install`'s code-base) (#207) +* Improve handling of async exceptions (#187) +* Detect & recover from local corruption of uncompressed index tarball (#196) +* Support `base-4.11` + 0.5.2.2 ------- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.2.2/hackage-security.cabal new/hackage-security-0.5.3.0/hackage-security.cabal --- old/hackage-security-0.5.2.2/hackage-security.cabal 2016-08-29 00:57:40.000000000 +0200 +++ new/hackage-security-0.5.3.0/hackage-security.cabal 2018-03-26 01:39:07.000000000 +0200 @@ -1,5 +1,7 @@ +cabal-version: 1.12 name: hackage-security -version: 0.5.2.2 +version: 0.5.3.0 + synopsis: Hackage security library description: The hackage security library provides both server and client utilities for securing the Hackage package server @@ -21,31 +23,30 @@ license: BSD3 license-file: LICENSE author: Edsko de Vries -maintainer: ed...@well-typed.com +maintainer: cabal-de...@haskell.org copyright: Copyright 2015-2016 Well-Typed LLP category: Distribution -homepage: https://github.com/well-typed/hackage-security -bug-reports: https://github.com/well-typed/hackage-security/issues +homepage: https://github.com/haskell/hackage-security +bug-reports: https://github.com/haskell/hackage-security/issues build-type: Simple -cabal-version: >=1.10 extra-source-files: ChangeLog.md source-repository head type: git - location: https://github.com/well-typed/hackage-security.git + location: https://github.com/haskell/hackage-security.git flag base48 - description: Are we using base 4.8 or later? + description: Are we using @base@ 4.8 or later? manual: False flag use-network-uri - description: Are we using network-uri? + description: Are we using @network-uri@? manual: False -Flag old-directory - description: Use directory < 1.2 and old-time +flag old-directory + description: Use @directory@ < 1.2 and @old-time@ manual: False default: False @@ -90,18 +91,19 @@ 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 Prelude -- We support ghc 7.4 (bundled with Cabal 1.14) and up - build-depends: base >= 4.5 && < 5, + build-depends: base >= 4.5 && < 4.12, base16-bytestring >= 0.1.1 && < 0.2, base64-bytestring >= 1.0 && < 1.1, bytestring >= 0.9 && < 0.11, - Cabal >= 1.14 && < 1.26, + Cabal >= 1.14 && < 2.4, containers >= 0.4 && < 0.6, - directory >= 1.1.0.2 && < 1.3, ed25519 >= 0.0 && < 0.1, filepath >= 1.2 && < 1.5, mtl >= 2.2 && < 2.3, @@ -111,16 +113,19 @@ -- 0.4.2 introduces TarIndex, 0.4.4 introduces more -- functionality, 0.5.0 changes type of serialise tar >= 0.5 && < 0.6, - time >= 1.2 && < 1.7, + time >= 1.2 && < 1.9, transformers >= 0.4 && < 0.6, zlib >= 0.5 && < 0.7, -- whatever versions are bundled with ghc: template-haskell, ghc-prim if flag(old-directory) - build-depends: directory < 1.2, old-time >= 1 && < 1.2 + build-depends: directory >= 1.1.0.2 && < 1.2, + old-time >= 1 && < 1.2 else - build-depends: directory >= 1.2 + 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 @@ -147,11 +152,10 @@ OverlappingInstances PackageImports UndecidableInstances + -- use the new stage1/cross-compile-friendly Quotes subset of TH for new GHCs if impl(ghc >= 8.0) - -- place holder until Hackage allows to edit in the new extension token - -- other-extensions: TemplateHaskellQuotes - other-extensions: + other-extensions: TemplateHaskellQuotes else other-extensions: TemplateHaskell @@ -160,7 +164,7 @@ if flag(base48) build-depends: base >= 4.8 else - build-depends: old-locale >= 1.0 + build-depends: base < 4.8, old-locale == 1.0.* -- The URI type got split out off the network package after version 2.5, and -- moved to a separate network-uri package. Since we don't need the rest of @@ -205,9 +209,7 @@ if impl(ghc >= 7.10) other-extensions: AllowAmbiguousTypes --- StaticPointers --- ^^^ Temporarily disabled because Hackage doesn't know yet about this --- extension and will therefore reject this package. + StaticPointers test-suite TestSuite type: exitcode-stdio-1.0 @@ -219,21 +221,25 @@ TestSuite.JSON TestSuite.PrivateKeys TestSuite.Util.StrictMVar - build-depends: base, + + -- inherited constraints from lib:hackage-security component + build-depends: hackage-security, + base, Cabal, containers, - HUnit, bytestring, - hackage-security, network-uri, tar, - tasty, - tasty-hunit, - tasty-quickcheck, - QuickCheck, - temporary, time, zlib + + -- dependencies exclusive to test-suite + build-depends: tasty == 1.0.*, + tasty-hunit == 0.10.*, + tasty-quickcheck == 0.10.*, + QuickCheck == 2.9.*, + temporary == 1.2.* + hs-source-dirs: tests default-language: Haskell2010 default-extensions: FlexibleContexts diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.2.2/src/Hackage/Security/Client/Repository/Cache.hs new/hackage-security-0.5.3.0/src/Hackage/Security/Client/Repository/Cache.hs --- old/hackage-security-0.5.2.2/src/Hackage/Security/Client/Repository/Cache.hs 2016-08-29 00:57:40.000000000 +0200 +++ new/hackage-security-0.5.3.0/src/Hackage/Security/Client/Repository/Cache.hs 2018-03-26 01:39:07.000000000 +0200 @@ -16,6 +16,7 @@ import Control.Exception import Control.Monad +import Control.Monad.IO.Class import Data.Maybe import Codec.Archive.Tar (Entries(..)) import Codec.Archive.Tar.Index (TarIndex, IndexBuilder, TarEntryOffset) @@ -29,6 +30,7 @@ import Hackage.Security.Client.Formats import Hackage.Security.TUF import Hackage.Security.Util.Checked +import Hackage.Security.Util.Exit import Hackage.Security.Util.IO import Hackage.Security.Util.Path @@ -65,21 +67,47 @@ unzipIndex :: IO () unzipIndex = do createDirectoryIfMissing True (takeDirectory indexUn) - shouldTryIncremenal <- cachedIndexProbablyValid - if shouldTryIncremenal - then unzipIncremenal - else unzipNonIncremenal + shouldTryIncremental <- cachedIndexProbablyValid + if shouldTryIncremental + then do + success <- unzipIncremental + unless success unzipNonIncremental + else unzipNonIncremental where - unzipIncremenal = do + unzipIncremental = do compressed <- readLazyByteString indexGz let uncompressed = GZip.decompress compressed - withFile indexUn ReadWriteMode $ \h -> do - currentSize <- hFileSize h + + -- compare prefix of old index with prefix of new index to + -- ensure that it's safe to incrementally append + (seekTo',newTail') <- withFile indexUn ReadMode $ \h -> + multipleExitPoints $ do + currentSize <- liftIO $ hFileSize h let seekTo = 0 `max` (currentSize - tarTrailer) - hSeek h AbsoluteSeek seekTo - BS.L.hPut h $ BS.L.drop (fromInteger seekTo) uncompressed + (newPrefix,newTail) = BS.L.splitAt (fromInteger seekTo) + uncompressed + + (oldPrefix,oldTrailer) <- BS.L.splitAt (fromInteger seekTo) <$> + liftIO (BS.L.hGetContents h) + + unless (oldPrefix == newPrefix) $ + exit (0,mempty) -- corrupted index.tar prefix - unzipNonIncremenal = do + -- sanity check: verify there's a 1KiB zero-filled trailer + unless (oldTrailer == tarTrailerBs) $ + exit (0,mempty) -- corrupted .tar trailer + + return (seekTo,newTail) + + if seekTo' <= 0 + then return False -- fallback to non-incremental update + else withFile indexUn ReadWriteMode $ \h -> do + -- everything seems fine; append the new data + liftIO $ hSeek h AbsoluteSeek seekTo' + liftIO $ BS.L.hPut h newTail' + return True + + unzipNonIncremental = do compressed <- readLazyByteString indexGz let uncompressed = GZip.decompress compressed withFile indexUn WriteMode $ \h -> @@ -108,6 +136,8 @@ tarTrailer :: Integer tarTrailer = 1024 + tarTrailerBs = BS.L.replicate (fromInteger tarTrailer) 0x00 + -- | Rebuild the tarball index -- -- Attempts to add to the existing index, if one exists. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.2.2/src/Hackage/Security/Client/Repository/Remote.hs new/hackage-security-0.5.3.0/src/Hackage/Security/Client/Repository/Remote.hs --- old/hackage-security-0.5.2.2/src/Hackage/Security/Client/Repository/Remote.hs 2016-08-29 00:57:40.000000000 +0200 +++ new/hackage-security-0.5.3.0/src/Hackage/Security/Client/Repository/Remote.hs 2018-03-26 01:39:07.000000000 +0200 @@ -30,7 +30,6 @@ import Control.Concurrent import Control.Exception import Control.Monad.Cont -import Control.Monad.Except import Data.List (nub, intercalate) import Data.Typeable import Network.URI hiding (uriPath, path) @@ -50,6 +49,7 @@ import Hackage.Security.Util.Path import Hackage.Security.Util.Pretty import Hackage.Security.Util.Some +import Hackage.Security.Util.Exit import qualified Hackage.Security.Client.Repository.Cache as Cache {------------------------------------------------------------------------------- @@ -445,6 +445,12 @@ (mustCache remoteFile) return (Some format, remoteTemp) + httpGetRange :: forall a. Throws SomeRemoteError + => [HttpRequestHeader] + -> URI + -> (Int, Int) + -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a) + -> IO a HttpLib{..} = cfgHttpLib {------------------------------------------------------------------------------- @@ -680,39 +686,3 @@ , temp ] -{------------------------------------------------------------------------------- - Auxiliary: multiple exit points --------------------------------------------------------------------------------} - --- | Multiple exit points --- --- We can simulate the imperative code --- --- > if (cond1) --- > return exp1; --- > if (cond2) --- > return exp2; --- > if (cond3) --- > return exp3; --- > return exp4; --- --- as --- --- > multipleExitPoints $ do --- > when (cond1) $ --- > exit exp1 --- > when (cond) $ --- > exit exp2 --- > when (cond) --- > exit exp3 --- > return exp4 -multipleExitPoints :: Monad m => ExceptT a m a -> m a -multipleExitPoints = liftM aux . runExceptT - where - aux :: Either a a -> a - aux (Left a) = a - aux (Right a) = a - --- | Function exit point (see 'multipleExitPoints') -exit :: Monad m => e -> ExceptT e m a -exit = throwError diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.2.2/src/Hackage/Security/Util/Checked.hs new/hackage-security-0.5.3.0/src/Hackage/Security/Util/Checked.hs --- old/hackage-security-0.5.2.2/src/Hackage/Security/Util/Checked.hs 2016-08-29 00:57:40.000000000 +0200 +++ new/hackage-security-0.5.3.0/src/Hackage/Security/Util/Checked.hs 2018-03-26 01:39:07.000000000 +0200 @@ -9,6 +9,8 @@ {-# LANGUAGE IncoherentInstances #-} #endif +{-# LANGUAGE DeriveDataTypeable#-} + -- | Checked exceptions module Hackage.Security.Util.Checked ( Throws @@ -25,6 +27,7 @@ import Control.Exception (Exception, IOException) import qualified Control.Exception as Base +import Data.Typeable (Typeable) #if __GLASGOW_HASKELL__ >= 708 import GHC.Prim (coerce) @@ -50,14 +53,48 @@ Base exceptions -------------------------------------------------------------------------------} +-- | Determine if an exception is asynchronous, based on its type. +isAsync :: Exception e => e -> Bool +#if MIN_VERSION_base(4, 7, 0) +isAsync e = + case Base.fromException $ Base.toException e of + Just Base.SomeAsyncException{} -> True + Nothing -> False +#else +-- Earlier versions of GHC had no SomeAsyncException. We have to +-- instead make up a list of async exceptions. +isAsync e = + let se = Base.toException e + in case () of + () + | Just (_ :: Base.AsyncException) <- Base.fromException se -> True + | show e == "<<timeout>>" -> True + | otherwise -> False +#endif + +-- | 'Base.catch', but immediately rethrows asynchronous exceptions +-- (as determined by 'isAsync'). +catchSync :: Exception e => IO a -> (e -> IO a) -> IO a +catchSync act onErr = act `Base.catch` \e -> + if isAsync e + then Base.throwIO e + else onErr e + +-- | Wraps up an async exception as a synchronous exception. +newtype SyncException = SyncException Base.SomeException + deriving (Show, Typeable) +instance Exception SyncException + -- | Throw a checked exception throwChecked :: (Exception e, Throws e) => e -> IO a -throwChecked = Base.throwIO +throwChecked e + | isAsync e = Base.throwIO $ SyncException $ Base.toException e + | otherwise = Base.throwIO e -- | Catch a checked exception catchChecked :: forall a e. Exception e => (Throws e => IO a) -> (e -> IO a) -> IO a -catchChecked act = Base.catch (unthrow (Proxy :: Proxy e) act) +catchChecked act = catchSync (unthrow (Proxy :: Proxy e) act) -- | 'catchChecked' with the arguments reversed handleChecked :: Exception e => (e -> IO a) -> (Throws e => IO a) -> IO a diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.2.2/src/Hackage/Security/Util/Exit.hs new/hackage-security-0.5.3.0/src/Hackage/Security/Util/Exit.hs --- old/hackage-security-0.5.2.2/src/Hackage/Security/Util/Exit.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/hackage-security-0.5.3.0/src/Hackage/Security/Util/Exit.hs 2018-03-26 01:39:07.000000000 +0200 @@ -0,0 +1,40 @@ +module Hackage.Security.Util.Exit where + +import Control.Monad.Except + +{------------------------------------------------------------------------------- + Auxiliary: multiple exit points +-------------------------------------------------------------------------------} + +-- | Multiple exit points +-- +-- We can simulate the imperative code +-- +-- > if (cond1) +-- > return exp1; +-- > if (cond2) +-- > return exp2; +-- > if (cond3) +-- > return exp3; +-- > return exp4; +-- +-- as +-- +-- > multipleExitPoints $ do +-- > when (cond1) $ +-- > exit exp1 +-- > when (cond2) $ +-- > exit exp2 +-- > when (cond3) $ +-- > exit exp3 +-- > return exp4 +multipleExitPoints :: Monad m => ExceptT a m a -> m a +multipleExitPoints = liftM aux . runExceptT + where + aux :: Either a a -> a + aux (Left a) = a + aux (Right a) = a + +-- | Function exit point (see 'multipleExitPoints') +exit :: Monad m => e -> ExceptT e m a +exit = throwError diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.2.2/src/Hackage/Security/Util/FileLock.hsc new/hackage-security-0.5.3.0/src/Hackage/Security/Util/FileLock.hsc --- old/hackage-security-0.5.2.2/src/Hackage/Security/Util/FileLock.hsc 1970-01-01 01:00:00.000000000 +0100 +++ new/hackage-security-0.5.3.0/src/Hackage/Security/Util/FileLock.hsc 2018-03-26 01:39:07.000000000 +0200 @@ -0,0 +1,202 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE InterruptibleFFI #-} +{-# 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 <windows.h> + +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 <sys/file.h> + +#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 >>= \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 + 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 >>= \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} + +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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.2.2/src/Hackage/Security/Util/IO.hs new/hackage-security-0.5.3.0/src/Hackage/Security/Util/IO.hs --- old/hackage-security-0.5.2.2/src/Hackage/Security/Util/IO.hs 2016-08-29 00:57:40.000000000 +0200 +++ new/hackage-security-0.5.3.0/src/Hackage/Security/Util/IO.hs 2018-03-26 01:39:07.000000000 +0200 @@ -7,12 +7,14 @@ , 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 @@ 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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.2.2/src/Text/JSON/Canonical.hs new/hackage-security-0.5.3.0/src/Text/JSON/Canonical.hs --- old/hackage-security-0.5.2.2/src/Text/JSON/Canonical.hs 2016-08-29 00:57:40.000000000 +0200 +++ new/hackage-security-0.5.3.0/src/Text/JSON/Canonical.hs 2018-03-26 01:39:07.000000000 +0200 @@ -321,8 +321,8 @@ jstring = doubleQuotes . hcat . map jchar jchar :: Char -> Doc -jchar '"' = Doc.char '\\' <> Doc.char '"' -jchar '\\' = Doc.char '\\' <> Doc.char '\\' +jchar '"' = Doc.char '\\' Doc.<> Doc.char '"' +jchar '\\' = Doc.char '\\' Doc.<> Doc.char '\\' jchar c = Doc.char c jarray :: [JSValue] -> Doc @@ -331,7 +331,7 @@ jobject :: [(String, JSValue)] -> Doc jobject = sep . punctuate' lbrace comma rbrace - . map (\(k,v) -> sep [jstring k <> colon, nest 2 (jvalue v)]) + . map (\(k,v) -> sep [jstring k Doc.<> colon, nest 2 (jvalue v)]) -- | Punctuate in this style: @@ -345,7 +345,7 @@ -- > ] -- punctuate' :: Doc -> Doc -> Doc -> [Doc] -> [Doc] -punctuate' l _ r [] = [l <> r] +punctuate' l _ r [] = [l Doc.<> r] punctuate' l _ r [x] = [l <+> x <+> r] punctuate' l p r (x:xs) = l <+> x : go xs where diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.2.2/tests/TestSuite.hs new/hackage-security-0.5.3.0/tests/TestSuite.hs --- old/hackage-security-0.5.2.2/tests/TestSuite.hs 2016-08-29 00:57:40.000000000 +0200 +++ new/hackage-security-0.5.3.0/tests/TestSuite.hs 2018-03-26 01:39:07.000000000 +0200 @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards, GADTs #-} +{-# LANGUAGE CPP, RecordWildCards, GADTs #-} module Main (main) where -- stdlib @@ -15,7 +15,11 @@ import qualified Data.ByteString.Lazy.Char8 as BS -- Cabal -import Distribution.Package (PackageName(..)) +#if MIN_VERSION_Cabal(2,0,0) +import Distribution.Package (mkPackageName) +#else +import Distribution.Package (PackageName(PackageName)) +#endif -- hackage-security import Hackage.Security.Client @@ -253,7 +257,7 @@ indexEntryContent entry @?= testEntrycontent case indexEntryPathParsed entry of Just (IndexPkgPrefs pkgname) -> do - pkgname @?= PackageName "foo" + pkgname @?= mkPackageName "foo" case indexEntryContentParsed entry of Right () -> return () _ -> fail "unexpected index entry content" @@ -263,7 +267,7 @@ where Right path = Tar.toTarPath False "foo/preferred-versions" testEntrycontent = BS.pack "foo >= 1" - testEntryIndexFile = IndexPkgPrefs (PackageName "foo") + testEntryIndexFile = IndexPkgPrefs (mkPackageName "foo") {------------------------------------------------------------------------------- @@ -503,3 +507,9 @@ -- | Return @Just@ the current time checkExpiry :: IO (Maybe UTCTime) checkExpiry = Just `fmap` getCurrentTime + +#if !MIN_VERSION_Cabal(2,0,0) +-- | Emulate Cabal2's @mkPackageName@ constructor-function +mkPackageName :: String -> PackageName +mkPackageName = PackageName +#endif