hackage-security 0.5.3.0 → 0.6.0.0

raw patch · 14 files changed

+269/−282 lines, 14 filesdep +aesondep +lukkodep +mtl-compatdep ~Cabaldep ~QuickCheckdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, lukko, mtl-compat, unordered-containers, vector

Dependency ranges changed: Cabal, QuickCheck, base, mtl, tasty, template-haskell, temporary, transformers

API changes (from Hackage documentation)

Files

• ChangeLog.md +15/−0
• hackage-security.cabal +45/−18
• src/Hackage/Security/Client/Repository.hs +27/−0
• src/Hackage/Security/Client/Repository/Cache.hs +13/−1
• src/Hackage/Security/Client/Repository/Local.hs +1/−1
• src/Hackage/Security/Client/Repository/Remote.hs +1/−1
• src/Hackage/Security/TUF/FileMap.hs +0/−12
• src/Hackage/Security/TUF/Snapshot.hs +7/−3
• src/Hackage/Security/TUF/Timestamp.hs +5/−1
• src/Hackage/Security/Util/FileLock.hsc +0/−202
• src/Hackage/Security/Util/IO.hs +91/−21
• src/Hackage/Security/Util/Lens.hs +17/−19
• tests/TestSuite.hs +27/−0
• tests/TestSuite/JSON.hs +20/−3

@@ -1,3 +1,18 @@+See also http://pvp.haskell.org/faq++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 ------- 

@@ -1,6 +1,6 @@ cabal-version:       1.12 name:                hackage-security-version:             0.5.3.0+version:             0.6.0.0  synopsis:            Hackage security library description:         The hackage security library provides both server and@@ -29,7 +29,10 @@ homepage:            https://github.com/haskell/hackage-security bug-reports:         https://github.com/haskell/hackage-security/issues build-type:          Simple+tested-with:         GHC==8.8.1, 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,40 +103,52 @@                        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.14,                        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.2,+                       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,+                       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-  build-tool-depends:  hsc2hs:hsc2hs >= 0.67 && <0.69+    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:     base       >= 4.10+   hs-source-dirs:      src   default-language:    Haskell2010   default-extensions:  DefaultSignatures@@ -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

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

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

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

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

@@ -13,8 +13,6 @@   , (!)   , insert   , fromList-    -- * Convenience accessors-  , lookupM     -- * Comparing file maps   , FileChange(..)   , fileMapChanges@@ -70,16 +68,6 @@  fromList :: [(TargetPath, FileInfo)] -> FileMap 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

@@ -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{..} 

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

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

@@ -1,21 +1,31 @@+{-# 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,21 +42,32 @@         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 -- @//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 . 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"+    -- 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) -    releaseLock (Just h) = hClose h+        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) =+        hClose h+#if MIN_VERSION_base(4,11,0)+        >> hUnlock h+#endif     releaseLock Nothing  = removeDirectory lock+#endif  {-------------------------------------------------------------------------------   Debugging

@@ -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 -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+over :: LensLike Identity s t a b -> (a -> b) -> s -> t+over l f = runIdentity . l (Identity . f)++set :: LensLike Identity s t a b -> b -> s -> t+set l = over l . const

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

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