Hello community, here is the log from the commit of package ghc-hackage-security for openSUSE:Leap:15.2 checked in at 2020-05-21 12:58:15 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Leap:15.2/ghc-hackage-security (Old) and /work/SRC/openSUSE:Leap:15.2/.ghc-hackage-security.new.2738 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-hackage-security" Thu May 21 12:58:15 2020 rev:13 rq:802895 version:0.6.0.1 Changes: -------- --- /work/SRC/openSUSE:Leap:15.2/ghc-hackage-security/ghc-hackage-security.changes 2020-03-10 17:14:57.353445191 +0100 +++ /work/SRC/openSUSE:Leap:15.2/.ghc-hackage-security.new.2738/ghc-hackage-security.changes 2020-05-21 12:58:16.578656148 +0200 @@ -1,0 +2,18 @@ +Wed May 6 06:54:16 UTC 2020 - psim...@suse.com + +- Update hackage-security to version 0.6.0.1. + * Fix bug in non-default `-lukko` build-configuration (#242) + * Add support for `template-haskell-2.16.0.0` (#240) + * Remove `Hackage.Security.TUF.FileMap.lookupM` + * Don't expose `Hackage.Security.Util.IO` module + * Don't expose `Hackage.Security.Util.Lens` module + * Report missing keys in `.meta` objects more appropriately as + `ReportSchemaErrors(expected)` instead of via `Monad(fail)` + * Add support for GHC 8.8 / base-4.13 + * Use `lukko` for file-locking + * Extend `LogMessage` to signal events for cache lock acquiring and release + * New `lockCacheWithLogger` operation + +- Remove obsolete patch "fix-ghc-8.8.x-build.patch". + +------------------------------------------------------------------- Old: ---- fix-ghc-8.8.x-build.patch hackage-security-0.5.3.0.tar.gz hackage-security.cabal New: ---- hackage-security-0.6.0.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-hackage-security.spec ++++++ --- /var/tmp/diff_new_pack.TKqZ0f/_old 2020-05-21 12:58:17.278657672 +0200 +++ /var/tmp/diff_new_pack.TKqZ0f/_new 2020-05-21 12:58:17.282657681 +0200 @@ -19,14 +19,12 @@ %global pkg_name hackage-security %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.5.3.0 +Version: 0.6.0.1 Release: 0 Summary: Hackage security library License: BSD-3-Clause 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/6.cabal#/%{pkg_name}.cabal -Patch01: https://raw.githubusercontent.com/hvr/head.hackage/master/patches/hackage-security-0.5.3.0.patch#/fix-ghc-8.8.x-build.patch BuildRequires: ghc-Cabal-devel BuildRequires: ghc-base16-bytestring-devel BuildRequires: ghc-base64-bytestring-devel @@ -36,6 +34,7 @@ BuildRequires: ghc-directory-devel BuildRequires: ghc-ed25519-devel BuildRequires: ghc-filepath-devel +BuildRequires: ghc-lukko-devel BuildRequires: ghc-mtl-devel BuildRequires: ghc-network-devel BuildRequires: ghc-network-uri-devel @@ -49,10 +48,13 @@ BuildRequires: ghc-zlib-devel %if %{with tests} BuildRequires: ghc-QuickCheck-devel +BuildRequires: ghc-aeson-devel BuildRequires: ghc-tasty-devel BuildRequires: ghc-tasty-hunit-devel BuildRequires: ghc-tasty-quickcheck-devel BuildRequires: ghc-temporary-devel +BuildRequires: ghc-unordered-containers-devel +BuildRequires: ghc-vector-devel %endif %description @@ -85,13 +87,9 @@ %prep %setup -q -n %{pkg_name}-%{version} -cp -p %{SOURCE1} %{pkg_name}.cabal -%patch01 -p1 -cabal-tweak-dep-ver base '< 4.13' '< 5' -cabal-tweak-dep-ver network-uri '< 2.7' '< 3' +cabal-tweak-dep-ver base64-bytestring '< 1.1' '< 2' %build -%define cabal_configure_options -fbase48 -fuse-network-uri %ghc_lib_build %install ++++++ hackage-security-0.5.3.0.tar.gz -> hackage-security-0.6.0.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.3.0/ChangeLog.md new/hackage-security-0.6.0.1/ChangeLog.md --- old/hackage-security-0.5.3.0/ChangeLog.md 2018-03-26 01:39:07.000000000 +0200 +++ new/hackage-security-0.6.0.1/ChangeLog.md 2001-09-09 03:46:40.000000000 +0200 @@ -1,3 +1,24 @@ +See also http://pvp.haskell.org/faq + +0.6.0.1 +------- + +* Fix bug in non-default `-lukko` build-configuration (#242) +* Add support for `template-haskell-2.16.0.0` (#240) + +0.6.0.0 +------- + +* Remove `Hackage.Security.TUF.FileMap.lookupM` +* Don't expose `Hackage.Security.Util.IO` module +* Don't expose `Hackage.Security.Util.Lens` module +* Report missing keys in `.meta` objects more appropriately as + `ReportSchemaErrors(expected)` instead of via `Monad(fail)` +* Add support for GHC 8.8 / base-4.13 +* Use `lukko` for file-locking +* Extend `LogMessage` to signal events for cache lock acquiring and release +* New `lockCacheWithLogger` operation + 0.5.3.0 ------- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.3.0/hackage-security.cabal new/hackage-security-0.6.0.1/hackage-security.cabal --- old/hackage-security-0.5.3.0/hackage-security.cabal 2018-03-26 01:39:07.000000000 +0200 +++ new/hackage-security-0.6.0.1/hackage-security.cabal 2001-09-09 03:46:40.000000000 +0200 @@ -1,6 +1,6 @@ cabal-version: 1.12 name: hackage-security -version: 0.5.3.0 +version: 0.6.0.1 synopsis: Hackage security library description: The hackage security library provides both server and @@ -29,6 +29,9 @@ homepage: https://github.com/haskell/hackage-security bug-reports: https://github.com/haskell/hackage-security/issues build-type: Simple +tested-with: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 + extra-source-files: ChangeLog.md @@ -50,6 +53,16 @@ manual: False default: False +flag mtl21 + description: Use @mtl@ < 2.2 and @mtl-compat@ + manual: False + default: False + +flag lukko + description: Use @lukko@ for file-locking, otherwise use @GHC.IO.Handle.Lock@ + manual: True + default: True + library -- Most functionality is exported through the top-level entry points .Client -- and .Server; the other exported modules are intended for qualified imports. @@ -67,8 +80,6 @@ Hackage.Security.Trusted Hackage.Security.TUF.FileMap Hackage.Security.Util.Checked - Hackage.Security.Util.IO - Hackage.Security.Util.Lens Hackage.Security.Util.Path Hackage.Security.Util.Pretty Hackage.Security.Util.Some @@ -92,39 +103,51 @@ Hackage.Security.TUF.Timestamp Hackage.Security.Util.Base64 Hackage.Security.Util.Exit - Hackage.Security.Util.FileLock + Hackage.Security.Util.IO Hackage.Security.Util.JSON + Hackage.Security.Util.Lens 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 && < 4.12, + build-depends: base >= 4.5 && < 4.15, base16-bytestring >= 0.1.1 && < 0.2, base64-bytestring >= 1.0 && < 1.1, bytestring >= 0.9 && < 0.11, - Cabal >= 1.14 && < 2.4, - containers >= 0.4 && < 0.6, + Cabal >= 1.14 && < 1.26 + || >= 2.0 && < 2.6 + || >= 3.0 && < 3.4, + containers >= 0.4 && < 0.7, ed25519 >= 0.0 && < 0.1, filepath >= 1.2 && < 1.5, - mtl >= 2.2 && < 2.3, parsec >= 3.1 && < 3.2, pretty >= 1.0 && < 1.2, cryptohash-sha256 >= 0.11 && < 0.12, -- 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.9, - transformers >= 0.4 && < 0.6, + template-haskell >= 2.7 && < 2.17, + time >= 1.2 && < 1.10, + transformers >= 0.3 && < 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.1.0.2 && < 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 && < 1.4 + + if flag(mtl21) + build-depends: mtl >= 2.1 && < 2.2, + mtl-compat >= 0.2 && < 0.3 + else + build-depends: mtl >= 2.2 && < 2.3 + + if flag(lukko) + build-depends: lukko >= 0.1 && < 0.2 else - build-depends: directory >= 1.2 && < 1.4 - build-tool-depends: hsc2hs:hsc2hs >= 0.67 && <0.69 + build-depends: base >= 4.10 hs-source-dirs: src default-language: Haskell2010 @@ -153,9 +176,9 @@ PackageImports UndecidableInstances - -- use the new stage1/cross-compile-friendly Quotes subset of TH for new GHCs + -- use the new stage1/cross-compile-friendly DeriveLift extension for GHC 8.0+ if impl(ghc >= 8.0) - other-extensions: TemplateHaskellQuotes + other-extensions: DeriveLift else other-extensions: TemplateHaskell @@ -200,7 +223,8 @@ -- dependency in network is not redundant.) if flag(use-network-uri) build-depends: network-uri >= 2.6 && < 2.7, - network >= 2.6 && < 2.7 + network >= 2.6 && < 2.9 + || >= 3.0 && < 3.2 else build-depends: network >= 2.5 && < 2.6 @@ -234,11 +258,14 @@ zlib -- dependencies exclusive to test-suite - build-depends: tasty == 1.0.*, + build-depends: tasty == 1.2.*, tasty-hunit == 0.10.*, tasty-quickcheck == 0.10.*, - QuickCheck == 2.9.*, - temporary == 1.2.* + QuickCheck >= 2.11 && <2.14, + aeson == 1.4.*, + vector == 0.12.*, + unordered-containers >=0.2.8.0 && <0.3, + temporary >= 1.2 && < 1.4 hs-source-dirs: tests default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.3.0/src/Hackage/Security/Client/Repository/Cache.hs new/hackage-security-0.6.0.1/src/Hackage/Security/Client/Repository/Cache.hs --- old/hackage-security-0.5.3.0/src/Hackage/Security/Client/Repository/Cache.hs 2018-03-26 01:39:07.000000000 +0200 +++ new/hackage-security-0.6.0.1/src/Hackage/Security/Client/Repository/Cache.hs 2001-09-09 03:46:40.000000000 +0200 @@ -12,6 +12,7 @@ , getIndexIdx , cacheRemoteFile , lockCache + , lockCacheWithLogger ) where import Control.Exception @@ -214,7 +215,18 @@ -- This avoids two concurrent processes updating the cache at the same time, -- provided they both take the lock. lockCache :: Cache -> IO () -> IO () -lockCache Cache{..} = withDirLock cacheRoot +lockCache Cache{..} = withDirLock (\_ -> return ()) cacheRoot + +-- | Variant of 'lockCache' which emits 'LogMessage's before and after +-- a possibly blocking file-locking system call +-- +-- @since 0.6.0 +lockCacheWithLogger :: (LogMessage -> IO ()) -> Cache -> IO () -> IO () +lockCacheWithLogger logger Cache{..} = withDirLock logger' cacheRoot + where + logger' (WithDirLockEventPre fn) = logger (LogLockWait fn) + logger' (WithDirLockEventPost fn) = logger (LogLockWaitDone fn) + logger' (WithDirLockEventUnlock fn) = logger (LogUnlock fn) {------------------------------------------------------------------------------- Auxiliary: tar diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.3.0/src/Hackage/Security/Client/Repository/Local.hs new/hackage-security-0.6.0.1/src/Hackage/Security/Client/Repository/Local.hs --- old/hackage-security-0.5.3.0/src/Hackage/Security/Client/Repository/Local.hs 2018-03-26 01:39:07.000000000 +0200 +++ new/hackage-security-0.6.0.1/src/Hackage/Security/Client/Repository/Local.hs 2001-09-09 03:46:40.000000000 +0200 @@ -51,7 +51,7 @@ , repClearCache = clearCache cache , repWithIndex = withIndex cache , repGetIndexIdx = getIndexIdx cache - , repLockCache = lockCache cache + , repLockCache = lockCacheWithLogger logger cache , repWithMirror = mirrorsUnsupported , repLog = logger , repLayout = repLayout diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.3.0/src/Hackage/Security/Client/Repository/Remote.hs new/hackage-security-0.6.0.1/src/Hackage/Security/Client/Repository/Remote.hs --- old/hackage-security-0.5.3.0/src/Hackage/Security/Client/Repository/Remote.hs 2018-03-26 01:39:07.000000000 +0200 +++ new/hackage-security-0.6.0.1/src/Hackage/Security/Client/Repository/Remote.hs 2001-09-09 03:46:40.000000000 +0200 @@ -178,7 +178,7 @@ , repClearCache = Cache.clearCache cache , repWithIndex = Cache.withIndex cache , repGetIndexIdx = Cache.getIndexIdx cache - , repLockCache = Cache.lockCache cache + , repLockCache = Cache.lockCacheWithLogger logger cache , repWithMirror = withMirror httpLib selectedMirror logger diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.3.0/src/Hackage/Security/Client/Repository.hs new/hackage-security-0.6.0.1/src/Hackage/Security/Client/Repository.hs --- old/hackage-security-0.5.3.0/src/Hackage/Security/Client/Repository.hs 2018-03-26 01:39:07.000000000 +0200 +++ new/hackage-security-0.6.0.1/src/Hackage/Security/Client/Repository.hs 2001-09-09 03:46:40.000000000 +0200 @@ -316,6 +316,27 @@ -- (we will try with a different mirror if any are available) | LogMirrorFailed MirrorDescription SomeException + -- | This log event is triggered before invoking a filesystem lock + -- operation that may block for a significant amount of time; once + -- the possibly blocking call completes successfully, + -- 'LogLockWaitDone' will be emitted. + -- + -- @since 0.6.0 + | LogLockWait (Path Absolute) + + -- | Denotes completion of the operation that advertised a + -- 'LogLockWait' event + -- + -- @since 0.6.0 + | LogLockWaitDone (Path Absolute) + + -- | Denotes the filesystem lock previously acquired (signaled by + -- 'LogLockWait') has been released. + -- + -- @since 0.6.0 + | LogUnlock (Path Absolute) + + -- | Records why we are downloading a file rather than updating it. data UpdateFailure = -- | Server does not support incremental downloads @@ -451,6 +472,12 @@ "Cannot update " ++ pretty file ++ " (" ++ pretty ex ++ ")" pretty (LogMirrorFailed mirror ex) = "Exception " ++ displayException ex ++ " when using mirror " ++ mirror + pretty (LogLockWait file) = + "Waiting to acquire cache lock on " ++ pretty file + pretty (LogLockWaitDone file) = + "Acquired cache lock on " ++ pretty file + pretty (LogUnlock file) = + "Released cache lock on " ++ pretty file instance Pretty UpdateFailure where pretty UpdateImpossibleUnsupported = diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.3.0/src/Hackage/Security/TUF/FileMap.hs new/hackage-security-0.6.0.1/src/Hackage/Security/TUF/FileMap.hs --- old/hackage-security-0.5.3.0/src/Hackage/Security/TUF/FileMap.hs 2018-03-26 01:39:07.000000000 +0200 +++ new/hackage-security-0.6.0.1/src/Hackage/Security/TUF/FileMap.hs 2001-09-09 03:46:40.000000000 +0200 @@ -13,8 +13,6 @@ , (!) , insert , fromList - -- * Convenience accessors - , lookupM -- * Comparing file maps , FileChange(..) , fileMapChanges @@ -72,16 +70,6 @@ fromList = FileMap . Map.fromList {------------------------------------------------------------------------------- - Convenience accessors --------------------------------------------------------------------------------} - -lookupM :: Monad m => FileMap -> TargetPath -> m FileInfo -lookupM m fp = - case lookup fp m of - Nothing -> fail $ "No entry for " ++ pretty fp ++ " in filemap" - Just nfo -> return nfo - -{------------------------------------------------------------------------------- Comparing filemaps -------------------------------------------------------------------------------} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.3.0/src/Hackage/Security/TUF/Patterns.hs new/hackage-security-0.6.0.1/src/Hackage/Security/TUF/Patterns.hs --- old/hackage-security-0.5.3.0/src/Hackage/Security/TUF/Patterns.hs 2018-03-26 01:39:07.000000000 +0200 +++ new/hackage-security-0.6.0.1/src/Hackage/Security/TUF/Patterns.hs 2001-09-09 03:46:40.000000000 +0200 @@ -4,7 +4,8 @@ -- It is currently unusued. {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE StandaloneDeriving #-} #else {-# LANGUAGE TemplateHaskell #-} #endif @@ -272,6 +273,11 @@ Left err -> fail $ "Invalid delegation: " ++ err Right del -> TH.lift del +#if __GLASGOW_HASKELL__ >= 800 +deriving instance TH.Lift (Pattern a) +deriving instance TH.Lift (Replacement a) +deriving instance TH.Lift Delegation +#else instance TH.Lift (Pattern a) where lift (PatFileConst fn) = [| PatFileConst fn |] lift (PatFileExt e) = [| PatFileExt e |] @@ -288,6 +294,7 @@ instance TH.Lift Delegation where lift (Delegation pat repl) = [| Delegation pat repl |] +#endif {------------------------------------------------------------------------------- JSON diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.3.0/src/Hackage/Security/TUF/Snapshot.hs new/hackage-security-0.6.0.1/src/Hackage/Security/TUF/Snapshot.hs --- old/hackage-security-0.5.3.0/src/Hackage/Security/TUF/Snapshot.hs 2018-03-26 01:39:07.000000000 +0200 +++ new/hackage-security-0.6.0.1/src/Hackage/Security/TUF/Snapshot.hs 2001-09-09 03:46:40.000000000 +0200 @@ -13,6 +13,7 @@ import Hackage.Security.TUF.Layout.Repo import Hackage.Security.TUF.Signed import qualified Hackage.Security.TUF.FileMap as FileMap +import Hackage.Security.Util.Pretty (pretty) {------------------------------------------------------------------------------- Datatypes @@ -76,9 +77,12 @@ snapshotVersion <- fromJSField enc "version" snapshotExpires <- fromJSField enc "expires" snapshotMeta <- fromJSField enc "meta" - snapshotInfoRoot <- FileMap.lookupM snapshotMeta (pathRoot repoLayout) - snapshotInfoMirrors <- FileMap.lookupM snapshotMeta (pathMirrors repoLayout) - snapshotInfoTarGz <- FileMap.lookupM snapshotMeta (pathIndexTarGz repoLayout) + let lookupMeta k = case FileMap.lookup k snapshotMeta of + Nothing -> expected ("\"" ++ pretty k ++ "\" entry in .meta object") Nothing + Just v -> pure v + snapshotInfoRoot <- lookupMeta (pathRoot repoLayout) + snapshotInfoMirrors <- lookupMeta (pathMirrors repoLayout) + snapshotInfoTarGz <- lookupMeta (pathIndexTarGz repoLayout) let snapshotInfoTar = FileMap.lookup (pathIndexTar repoLayout) snapshotMeta return Snapshot{..} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.3.0/src/Hackage/Security/TUF/Timestamp.hs new/hackage-security-0.6.0.1/src/Hackage/Security/TUF/Timestamp.hs --- old/hackage-security-0.5.3.0/src/Hackage/Security/TUF/Timestamp.hs 2018-03-26 01:39:07.000000000 +0200 +++ new/hackage-security-0.6.0.1/src/Hackage/Security/TUF/Timestamp.hs 2001-09-09 03:46:40.000000000 +0200 @@ -13,6 +13,7 @@ import Hackage.Security.TUF.Layout.Repo import Hackage.Security.TUF.Signed import qualified Hackage.Security.TUF.FileMap as FileMap +import Hackage.Security.Util.Pretty (pretty) {------------------------------------------------------------------------------- Datatypes @@ -56,7 +57,10 @@ timestampVersion <- fromJSField enc "version" timestampExpires <- fromJSField enc "expires" timestampMeta <- fromJSField enc "meta" - timestampInfoSnapshot <- FileMap.lookupM timestampMeta (pathSnapshot repoLayout) + let lookupMeta k = case FileMap.lookup k timestampMeta of + Nothing -> expected ("\"" ++ pretty k ++ "\" entry in .meta object") Nothing + Just v -> pure v + timestampInfoSnapshot <- lookupMeta (pathSnapshot repoLayout) return Timestamp{..} instance (MonadKeys m, MonadReader RepoLayout m) => FromJSON m (Signed Timestamp) where diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.3.0/src/Hackage/Security/Util/FileLock.hsc new/hackage-security-0.6.0.1/src/Hackage/Security/Util/FileLock.hsc --- old/hackage-security-0.5.3.0/src/Hackage/Security/Util/FileLock.hsc 2018-03-26 01:39:07.000000000 +0200 +++ new/hackage-security-0.6.0.1/src/Hackage/Security/Util/FileLock.hsc 1970-01-01 01:00:00.000000000 +0100 @@ -1,202 +0,0 @@ -{-# 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.3.0/src/Hackage/Security/Util/IO.hs new/hackage-security-0.6.0.1/src/Hackage/Security/Util/IO.hs --- old/hackage-security-0.5.3.0/src/Hackage/Security/Util/IO.hs 2018-03-26 01:39:07.000000000 +0200 +++ new/hackage-security-0.6.0.1/src/Hackage/Security/Util/IO.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,20 +1,30 @@ +{-# LANGUAGE CPP #-} module Hackage.Security.Util.IO ( -- * Miscelleneous getFileSize , handleDoesNotExist + , WithDirLockEvent(..) , withDirLock -- * Debugging , timedIO ) where -import Control.Monad (unless) +import Control.Concurrent (threadDelay) 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) + +#ifdef MIN_VERSION_lukko +import Lukko (FD, fileLockingSupported, fdOpen, fdClose, fdLock, fdUnlock, LockMode(ExclusiveLock)) +#else +import GHC.IO.Handle.Lock (hLock, LockMode(ExclusiveLock), FileLockingNotSupported) +#if MIN_VERSION_base(4,11,0) +import GHC.IO.Handle.Lock (hUnlock) +#endif +#endif {------------------------------------------------------------------------------- Miscelleneous @@ -32,12 +42,21 @@ then return Nothing else throwIO e + +data WithDirLockEvent + = WithDirLockEventPre (Path Absolute) + | WithDirLockEventPost (Path Absolute) + | WithDirLockEventUnlock (Path Absolute) + -- | 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. +-- Blocks if the lock is already present. +-- +-- The logger callback passed as first argument is invoked before and +-- after acquiring a lock, and after unlocking. -- -- May fallback to locking via creating a directory: -- Given a file @/path/to@, we do this by attempting to create the directory @@ -45,8 +64,10 @@ -- 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 . const +withDirLock :: (WithDirLockEvent -> IO ()) -> Path Absolute -> IO a -> IO a +withDirLock logger dir + = bracket takeLock (\h -> releaseLock h >> logger (WithDirLockEventUnlock lock)) + . const where lock :: Path Absolute lock = dir </> fragment "hackage-security-lock" @@ -54,29 +75,78 @@ lock' :: FilePath lock' = toFilePath lock + me = "Hackage.Security.Util.IO.withDirLock: " + + wrapLog :: IO a -> IO a + wrapLog op = do + logger (WithDirLockEventPre lock) + h <- op + logger (WithDirLockEventPost lock) + return h + +#ifdef MIN_VERSION_lukko + takeLock :: IO FD + takeLock + | fileLockingSupported = do + h <- fdOpen lock' + wrapLog (fdLock h ExclusiveLock `onException` fdClose h) + return h + | otherwise = wrapLog takeDirLock + where + takeDirLock :: IO FD + takeDirLock = handle onCreateDirError $ do + createDirectory lock + return (undefined :: FD) + + onCreateDirError :: IOError -> IO FD + onCreateDirError ioe + | isAlreadyExistsError ioe = threadDelay (1*1000*1000) >> takeDirLock + | otherwise = fail (me++"error creating directory lock: "++show ioe) + + releaseLock h + | fileLockingSupported = do + fdUnlock h + fdClose h + | otherwise = + removeDirectory lock + +#else takeLock = do h <- openFile lock' ReadWriteMode - handle (takeDirLock h) $ do - gotlock <- hTryLock h ExclusiveLock - unless gotlock $ - fail $ "hTryLock: lock already exists: " ++ lock' + wrapLog $ handle (fallbackToDirLock h) $ do + hLock h ExclusiveLock 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 + -- If file locking isn't supported then we fallback to directory locking, + -- polling if necessary. + fallbackToDirLock :: Handle -> FileLockingNotSupported -> IO (Maybe Handle) + fallbackToDirLock h _ = takeDirLock >> return Nothing + where + takeDirLock :: IO () + takeDirLock = do + -- We fallback to directory locking + -- so we need to cleanup lock file first: close and remove + hClose h + handle onIOError (removeFile lock) + handle onCreateDirError (createDirectory lock) + + onCreateDirError :: IOError -> IO () + onCreateDirError ioe + | isAlreadyExistsError ioe = threadDelay (1*1000*1000) >> takeDirLock + | otherwise = fail (me++"error creating directory lock: "++show ioe) + + onIOError :: IOError -> IO () + onIOError _ = hPutStrLn stderr + (me++"cannot remove lock file before directory lock fallback") + + releaseLock (Just h) = +#if MIN_VERSION_base(4,11,0) + hUnlock h >> +#endif + hClose h releaseLock Nothing = removeDirectory lock +#endif {------------------------------------------------------------------------------- Debugging diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.3.0/src/Hackage/Security/Util/Lens.hs new/hackage-security-0.6.0.1/src/Hackage/Security/Util/Lens.hs --- old/hackage-security-0.5.3.0/src/Hackage/Security/Util/Lens.hs 2018-03-26 01:39:07.000000000 +0200 +++ new/hackage-security-0.6.0.1/src/Hackage/Security/Util/Lens.hs 2001-09-09 03:46:40.000000000 +0200 @@ -7,11 +7,11 @@ -- * Generic definitions Lens , Lens' + , Traversal + , Traversal' , get - , modify + , over , set - -- * Specific lenses - , lookupM ) where import Control.Applicative @@ -22,27 +22,25 @@ -------------------------------------------------------------------------------} -- | Polymorphic lens -type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t +type Lens s t a b = forall f. Functor f => LensLike f s t a b -- | Monomorphic lens type Lens' s a = Lens s s a a -get :: Lens' s a -> s -> a -get l = getConst . l Const +-- | Polymorphic traversal +type Traversal s t a b = forall f. Applicative f => LensLike f s t a b -modify :: Lens s t a b -> (a -> b) -> s -> t -modify l f = runIdentity . l (Identity . f) +-- | Monomorphic traversal +type Traversal' s a = Traversal s s a a -set :: Lens s t a b -> b -> s -> t -set l = modify l . const +type LensLike f s t a b = (a -> f b) -> s -> f t +type LensLike' f s a = LensLike f s s a a -{------------------------------------------------------------------------------- - Specific lenses --------------------------------------------------------------------------------} +get :: LensLike' (Const a) s a -> s -> a +get l = getConst . l Const + +over :: LensLike Identity s t a b -> (a -> b) -> s -> t +over l f = runIdentity . l (Identity . f) -lookupM :: forall a b. (Eq a, Monoid b) => a -> Lens' [(a, b)] b -lookupM a f = go - where - go [] = (\b' -> [(a, b')] ) <$> f mempty - go ((a', b):xs) | a == a' = (\b' -> (a, b'):xs ) <$> f b - | otherwise = (\xs' -> (a', b):xs') <$> go xs +set :: LensLike Identity s t a b -> b -> s -> t +set l = over l . const diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.3.0/tests/TestSuite/JSON.hs new/hackage-security-0.6.0.1/tests/TestSuite/JSON.hs --- old/hackage-security-0.5.3.0/tests/TestSuite/JSON.hs 2018-03-26 01:39:07.000000000 +0200 +++ new/hackage-security-0.6.0.1/tests/TestSuite/JSON.hs 2001-09-09 03:46:40.000000000 +0200 @@ -3,6 +3,7 @@ prop_roundtrip_canonical, prop_roundtrip_pretty, prop_canonical_pretty, + prop_aeson_canonical, ) where -- stdlib @@ -16,8 +17,13 @@ -- hackage-security import Text.JSON.Canonical +-- aeson +import Data.Aeson (Value (..), eitherDecode) +import Data.String (fromString) +import qualified Data.Vector as V +import qualified Data.HashMap.Strict as HM -prop_roundtrip_canonical, prop_roundtrip_pretty, prop_canonical_pretty +prop_aeson_canonical, prop_roundtrip_canonical, prop_roundtrip_pretty, prop_canonical_pretty :: JSValue -> Bool prop_roundtrip_canonical jsval = @@ -30,6 +36,9 @@ parseCanonicalJSON (renderCanonicalJSON jsval) == fmap canonicalise (parseCanonicalJSON (BS.pack (prettyCanonicalJSON jsval))) +prop_aeson_canonical jsval = + eitherDecode (renderCanonicalJSON jsval) == Right (toAeson (canonicalise jsval)) + canonicalise :: JSValue -> JSValue canonicalise v@JSNull = v canonicalise v@(JSBool _) = v @@ -46,12 +55,13 @@ [ (1, pure JSNull) , (1, JSBool <$> arbitrary) , (2, JSNum <$> arbitrary) - , (2, JSString <$> arbitrary) + , (2, JSString . getASCIIString <$> arbitrary) , (3, JSArray <$> resize (sz `div` 2) arbitrary) - , (3, JSObject . noDupFields <$> resize (sz `div` 2) arbitrary) + , (3, JSObject . mapFirst getASCIIString . noDupFields <$> resize (sz `div` 2) arbitrary) ] where noDupFields = nubBy (\(x,_) (y,_) -> x==y) + mapFirst f = map (\(x, y) -> (f x, y)) shrink JSNull = [] shrink (JSBool _) = [] @@ -62,6 +72,13 @@ where shrinkSnd (a,b) = [ (a,b') | b' <- shrink b ] +toAeson :: JSValue -> Value +toAeson JSNull = Null +toAeson (JSBool b) = Bool b +toAeson (JSNum n) = Number (fromIntegral n) +toAeson (JSString s) = String (fromString s) +toAeson (JSArray xs) = Array $ V.fromList [ toAeson x | x <- xs ] +toAeson (JSObject xs) = Object $ HM.fromList [ (fromString k, toAeson v) | (k, v) <- xs ] instance Arbitrary Int54 where arbitrary = fromIntegral <$> diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hackage-security-0.5.3.0/tests/TestSuite.hs new/hackage-security-0.6.0.1/tests/TestSuite.hs --- old/hackage-security-0.5.3.0/tests/TestSuite.hs 2018-03-26 01:39:07.000000000 +0200 +++ new/hackage-security-0.6.0.1/tests/TestSuite.hs 2001-09-09 03:46:40.000000000 +0200 @@ -70,6 +70,7 @@ testProperty "prop_roundtrip_canonical" JSON.prop_roundtrip_canonical , testProperty "prop_roundtrip_pretty" JSON.prop_roundtrip_pretty , testProperty "prop_canonical_pretty" JSON.prop_canonical_pretty + , testProperty "prop_aeson_canonical" JSON.prop_aeson_canonical ] ] @@ -283,6 +284,9 @@ , downloading isMirrors , noLocalCopy , downloading isIndex + , lockingWait + , lockingWaitDone + , lockingRelease ] -- | Log messages when we do a check for updates and there are no changes @@ -290,6 +294,9 @@ msgsNoUpdates = [ selectedMirror inMemURI , downloading isTimestamp + , lockingWait + , lockingWaitDone + , lockingRelease ] -- | Log messages we expect when the timestamp and snapshot have been resigned @@ -298,6 +305,9 @@ selectedMirror inMemURI , downloading isTimestamp , downloading isSnapshot + , lockingWait + , lockingWaitDone + , lockingRelease ] -- | Log messages we expect when the timestamp key has been rolled over @@ -307,12 +317,18 @@ , downloading isTimestamp , verificationError $ unknownKeyError timestampPath , downloading isRoot + , lockingWait + , lockingWaitDone + , lockingRelease , downloading isTimestamp , downloading isSnapshot -- Since we delete the timestamp and snapshot on a root info change, -- we will then conclude that we need to update the mirrors and the index. , downloading isMirrors , updating isIndex + , lockingWait + , lockingWaitDone + , lockingRelease ] {------------------------------------------------------------------------------- @@ -335,6 +351,14 @@ updating isFile (LogUpdating file) = isFile file updating _ _ = False +lockingWait, lockingWaitDone, lockingRelease :: LogMessage -> Bool +lockingWait (LogLockWait _) = True +lockingWait _ = False +lockingWaitDone (LogLockWaitDone _) = True +lockingWaitDone _ = False +lockingRelease (LogUnlock _) = True +lockingRelease _ = False + expired :: TargetPath -> VerificationError -> Bool expired f (VerificationErrorExpired f') = f == f' expired _ _ = False @@ -493,6 +517,9 @@ bootstrapMsgs :: [LogMessage -> Bool] bootstrapMsgs = [ selectedMirror inMemURI , downloading isRoot + , lockingWait + , lockingWaitDone + , lockingRelease ] layout :: RepoLayout