hackage-security 0.5.2.2 → 0.5.3.0

raw patch · 10 files changed

+428/−93 lines, 10 filesdep −HUnitdep ~Cabaldep ~QuickCheckdep ~basenew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: HUnit

Dependency ranges changed: Cabal, QuickCheck, base, containers, directory, network, old-locale, tasty, tasty-hunit, tasty-quickcheck, temporary, time

API changes (from Hackage documentation)

Files

• ChangeLog.md +9/−0
• hackage-security.cabal +37/−31
• src/Hackage/Security/Client/Repository/Cache.hs +40/−10
• src/Hackage/Security/Client/Repository/Remote.hs +7/−37
• src/Hackage/Security/Util/Checked.hs +39/−2
• src/Hackage/Security/Util/Exit.hs +40/−0
• src/Hackage/Security/Util/FileLock.hsc +202/−0
• src/Hackage/Security/Util/IO.hs +36/−5
• src/Text/JSON/Canonical.hs +4/−4
• tests/TestSuite.hs +14/−4

@@ -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 ------- 

@@ -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:          edsko@well-typed.com+maintainer:          cabal-devel@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

@@ -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 -        unzipNonIncremenal = do+            (oldPrefix,oldTrailer) <- BS.L.splitAt (fromInteger seekTo) <$>+                                      liftIO (BS.L.hGetContents h)++            unless (oldPrefix == newPrefix) $+              exit (0,mempty) -- corrupted index.tar prefix++            -- 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 ->@@ -107,6 +135,8 @@      tarTrailer :: Integer     tarTrailer = 1024++    tarTrailerBs = BS.L.replicate (fromInteger tarTrailer) 0x00  -- | Rebuild the tarball index --

@@ -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

@@ -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

@@ -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

@@ -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 */

@@ -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

@@ -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

@@ -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