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 - [email protected]
+
+- 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: [email protected]
+maintainer: [email protected]
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
