pantry 0.5.1.2 → 0.5.1.3
raw patch · 7 files changed
+100/−50 lines, 7 files
Files
- ChangeLog.md +4/−0
- pantry.cabal +2/−2
- src/Pantry.hs +15/−9
- src/Pantry/Archive.hs +33/−21
- src/Pantry/Hackage.hs +10/−9
- src/Pantry/Internal/Stackage.hs +1/−0
- src/Pantry/Storage.hs +35/−9
ChangeLog.md view
@@ -1,5 +1,9 @@ # Changelog for pantry +## v0.5.1.3++* Handle case where tree exists in cache by blobs are missing [#27](https://github.com/commercialhaskell/pantry/issues/27)+ ## v0.5.1.2 * Skip a test for [#26](https://github.com/commercialhaskell/pantry/issues/26)
pantry.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: c82a5e7314bb33a5eb19cc8ee7765da335798892a7c5e874cca2a8cfc553b69d+-- hash: 550119d6be48973b6e1944d695a00d4bb9d14b12ef305a46d00eb6724877446c name: pantry-version: 0.5.1.2+version: 0.5.1.3 synopsis: Content addressable Haskell package management description: Please see the README on Github at <https://github.com/commercialhaskell/pantry#readme> category: Development
src/Pantry.hs view
@@ -438,14 +438,20 @@ identifier <- getRawPackageLocationIdent rawPackageLocationImmutable case findCabalOrHpackFile rawPackageLocationImmutable tree of- Just buildFile ->- void- (withStorage- (storeTree- rawPackageLocationImmutable- identifier- tree- buildFile))+ Just buildFile -> withStorage $ do+ ecachedTree <- loadCachedTree tree+ case ecachedTree of+ Left e ->+ lift $ logWarn+ ("Loading cached tree after download from Casa failed on " <>+ display rawPackageLocationImmutable <> ": " <>+ displayShow e)+ Right cachedTree ->+ void $ storeTree+ rawPackageLocationImmutable+ identifier+ cachedTree+ buildFile Nothing -> logWarn ("Unable to find build file for package: " <>@@ -958,7 +964,7 @@ Nothing -> byThirdParty (isJust mpackage) where byThirdParty warnAboutMissingSizeSha = do- (sha, size, package) <- getArchive pl archive rpm+ (sha, size, package, _cachedTree) <- getArchive pl archive rpm when warnAboutMissingSizeSha (warnWith sha size) -- (getArchive checks archive and package metadata) let RawArchive loc _ _ subdir = archive
src/Pantry/Archive.hs view
@@ -63,8 +63,8 @@ getArchiveKey rpli archive rpm = packageTreeKey <$> getArchivePackage rpli archive rpm -- potential optimization -thd3 :: (a, b, c) -> c-thd3 (_, _, z) = z+thd4 :: (a, b, c, d) -> c+thd4 (_, _, z, _) = z getArchivePackage :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack)@@ -72,29 +72,41 @@ -> RawArchive -> RawPackageMetadata -> RIO env Package-getArchivePackage rpli archive rpm = thd3 <$> getArchive rpli archive rpm+getArchivePackage rpli archive rpm = thd4 <$> getArchive rpli archive rpm getArchive :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack) => RawPackageLocationImmutable -- ^ for exceptions -> RawArchive -> RawPackageMetadata- -> RIO env (SHA256, FileSize, Package)+ -> RIO env (SHA256, FileSize, Package, CachedTree) getArchive rpli archive rpm = do- -- Check if the value is in the archive, and use it if possible+ -- Check if the value is in the cache, and use it if possible mcached <- loadCache rpli archive- cached@(_, _, pa) <-+ -- Ensure that all of the blobs referenced exist in the cache+ -- See: https://github.com/commercialhaskell/pantry/issues/27+ mtree <- case mcached of- Just stored -> pure stored+ Nothing -> pure Nothing+ Just (_, _, pa) -> do+ etree <- withStorage $ loadCachedTree $ packageTree pa+ case etree of+ Left e -> do+ logDebug $ "getArchive of " <> displayShow rpli <> ": loadCachedTree failed: " <> displayShow e+ pure Nothing+ Right x -> pure $ Just x+ cached@(_, _, pa, _) <-+ case (mcached, mtree) of+ (Just (a, b, c), Just d) -> pure (a, b, c, d) -- Not in the archive. Load the archive. Completely ignore the -- PackageMetadata for now, we'll check that the Package -- info matches next.- Nothing -> withArchiveLoc archive $ \fp sha size -> do- pa <- parseArchive rpli archive fp+ _ -> withArchiveLoc archive $ \fp sha size -> do+ (pa, tree) <- parseArchive rpli archive fp -- Storing in the cache exclusively uses information we have -- about the archive itself, not metadata from the user. storeCache archive sha size pa- pure (sha, size, pa)+ pure (sha, size, pa, tree) either throwIO (\_ -> pure cached) $ checkPackageMetadata rpli rpm pa @@ -335,7 +347,7 @@ => RawPackageLocationImmutable -> RawArchive -> FilePath -- ^ file holding the archive- -> RIO env Package+ -> RIO env (Package, CachedTree) parseArchive rpli archive fp = do let loc = raLocation archive getFiles [] = throwIO $ UnknownArchiveType loc@@ -413,20 +425,20 @@ Left e -> throwIO $ UnsupportedTarball loc $ T.pack e Right safeFiles -> do let toSave = Set.fromList $ map (seSource . snd) safeFiles- (blobs :: Map FilePath BlobKey) <-+ (blobs :: Map FilePath (BlobKey, BlobId)) <- foldArchive loc fp at mempty $ \m me -> if mePath me `Set.member` toSave then do bs <- mconcat <$> sinkList- (_, blobKey) <- lift $ withStorage $ storeBlob bs- pure $ Map.insert (mePath me) blobKey m+ (blobId, blobKey) <- lift $ withStorage $ storeBlob bs+ pure $ Map.insert (mePath me) (blobKey, blobId) m else pure m- tree <- fmap (TreeMap . Map.fromList) $ for safeFiles $ \(sfp, se) ->+ tree :: CachedTree <- fmap (CachedTreeMap . Map.fromList) $ for safeFiles $ \(sfp, se) -> case Map.lookup (seSource se) blobs of Nothing -> error $ "Impossible: blob not found for: " ++ seSource se- Just blobKey -> pure (sfp, TreeEntry blobKey (seType se))+ Just (blobKey, blobId) -> pure (sfp, (TreeEntry blobKey (seType se), blobId)) -- parse the cabal file and ensure it has the right name- buildFile <- findCabalOrHpackFile rpli tree+ buildFile <- findCabalOrHpackFile rpli $ unCachedTree tree (buildFilePath, buildFileBlobKey, buildFileEntry) <- case buildFile of BFCabal fpath te@(TreeEntry key _) -> pure (fpath, key, te) BFHpack te@(TreeEntry key _) -> pure (hpackSafeFilePath, key, te)@@ -437,7 +449,7 @@ Just bs -> pure bs cabalBs <- case buildFile of BFCabal _ _ -> pure bs- BFHpack _ -> snd <$> hpackToCabal rpli tree+ BFHpack _ -> snd <$> hpackToCabal rpli (unCachedTree tree) (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBs let ident@(PackageIdentifier name _) = package $ packageDescription gpd case buildFile of@@ -454,12 +466,12 @@ hpackSoftwareVersion <- hpackVersion let cabalTreeEntry = TreeEntry cabalKey (teType buildFileEntry) pure $ PCHpack $ PHpack { phOriginal = buildFileEntry, phGenerated = cabalTreeEntry, phVersion = hpackSoftwareVersion}- pure Package+ pure (Package { packageTreeKey = treeKey'- , packageTree = tree+ , packageTree = unCachedTree tree , packageCabalEntry = packageCabal , packageIdent = ident- }+ }, tree) -- | Find all of the files in the Map with the given directory as a -- prefix. Directory is given without trailing slash. Returns the
src/Pantry/Hackage.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} module Pantry.Hackage ( updateHackageIndex , forceUpdateHackageIndex@@ -610,8 +611,8 @@ , T.pack $ Distribution.Text.display ver , ".tar.gz" ]- package <-- getArchivePackage+ (_, _, package, cachedTree) <-+ getArchive rpli RawArchive { raLocation = ALUrl url@@ -624,16 +625,14 @@ , rpmVersion = Just ver , rpmTreeKey = Nothing -- with a revision cabal file will differ giving a different tree }- case packageTree package of- TreeMap m -> do+ case cachedTree of+ CachedTreeMap m -> do let ft = case packageCabalEntry package of PCCabalFile (TreeEntry _ ft') -> ft' _ -> error "Impossible: Hackage does not support hpack" cabalEntry = TreeEntry cabalFileKey ft- tree' = TreeMap $ Map.insert (cabalFileName name) cabalEntry m- ident = PackageIdentifier name ver- cabalBS <-+ (cabalBS, cabalBlobId) <- withStorage $ do let BlobKey sha' _ = cabalFileKey mcabalBS <- loadBlobBySHA sha'@@ -641,7 +640,9 @@ Nothing -> error $ "Invariant violated, cabal file key: " ++ show cabalFileKey- Just bid -> loadBlobById bid+ Just bid -> (, bid) <$> loadBlobById bid+ let tree' = CachedTreeMap $ Map.insert (cabalFileName name) (cabalEntry, cabalBlobId) m+ ident = PackageIdentifier name ver (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBS let gpdIdent = Cabal.package $ Cabal.packageDescription gpd when (ident /= gpdIdent) $@@ -657,7 +658,7 @@ { htrPackage = Package { packageTreeKey = treeKey'- , packageTree = tree'+ , packageTree = unCachedTree tree' , packageIdent = ident , packageCabalEntry = PCCabalFile cabalEntry }
src/Pantry/Internal/Stackage.hs view
@@ -21,6 +21,7 @@ , TreeId , Unique(..) , Version+ , versionVersion , VersionId , getBlobKey , getPackageNameById
src/Pantry/Storage.hs view
@@ -15,6 +15,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-} module Pantry.Storage ( SqlBackend , initStorage@@ -70,6 +71,7 @@ , VersionId , ModuleNameId , Version+ , versionVersion , Unique(..) , EntityField(..) -- avoid warnings@@ -90,6 +92,9 @@ , UrlBlobId , SnapshotCacheId , PackageExposedModuleId+ , loadCachedTree+ , CachedTree (..)+ , unCachedTree ) where import RIO hiding (FilePath)@@ -676,16 +681,23 @@ where fp = T.unpack (P.unSafeFilePath sfp) +-- | A tree that has already been stored in the database+newtype CachedTree+ = CachedTreeMap (Map SafeFilePath (P.TreeEntry, BlobId))+ deriving Show +unCachedTree :: CachedTree -> P.Tree+unCachedTree (CachedTreeMap m) = P.TreeMap $ fst <$> m+ storeTree :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -- ^ for exceptions -> P.PackageIdentifier- -> P.Tree+ -> CachedTree -> P.BuildFile -> ReaderT SqlBackend (RIO env) (TreeId, P.TreeKey)-storeTree rpli (P.PackageIdentifier name version) tree@(P.TreeMap m) buildFile = do- (bid, blobKey) <- storeBlob $ P.renderTree tree+storeTree rpli (P.PackageIdentifier name version) tree@(CachedTreeMap m) buildFile = do+ (bid, blobKey) <- storeBlob $ P.renderTree $ unCachedTree tree (cabalid, ftype) <- case buildFile of P.BFHpack (P.TreeEntry _ ftype) -> pure (Nothing, ftype) P.BFCabal _ (P.TreeEntry (P.BlobKey btypeSha _) ftype) -> do@@ -708,13 +720,8 @@ (tid, pTreeKey) <- case etid of Left (Entity tid _) -> pure (tid, P.TreeKey blobKey) -- already in database, assume it matches Right tid -> do- for_ (Map.toList m) $ \(sfp, P.TreeEntry blobKey' ft) -> do+ for_ (Map.toList m) $ \(sfp, (P.TreeEntry _blobKey ft, bid')) -> do sfpid <- getFilePathId sfp- mbid <- getBlobId blobKey'- bid' <-- case mbid of- Nothing -> error $ "Cannot store tree, contains unknown blob: " ++ show blobKey'- Just bid' -> pure bid' insert_ TreeEntry { treeEntryTree = tid , treeEntryPath = sfpid@@ -1174,3 +1181,22 @@ ] where go (Single (P.PackageNameP m)) = m++data LoadCachedTreeException = MissingBlob !BlobKey+ deriving (Show, Typeable)+instance Exception LoadCachedTreeException++-- | Ensure that all blobs needed for this package are present in the cache+loadCachedTree :: forall env. P.Tree -> ReaderT SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)+loadCachedTree (P.TreeMap m) =+ try $ CachedTreeMap <$> traverse loadEntry m+ where+ loadEntry :: P.TreeEntry -> ReaderT SqlBackend (RIO env) (P.TreeEntry, BlobId)+ loadEntry te = (te, ) <$> loadBlob' (P.teBlob te)++ loadBlob' :: BlobKey -> ReaderT SqlBackend (RIO env) BlobId+ loadBlob' blobKey@(P.BlobKey sha _) = do+ mbid <- loadBlobBySHA sha+ case mbid of+ Nothing -> throwIO $ MissingBlob blobKey+ Just bid -> pure bid