diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/pantry.cabal b/pantry.cabal --- a/pantry.cabal +++ b/pantry.cabal @@ -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 category: Development diff --git a/src/Pantry.hs b/src/Pantry.hs --- a/src/Pantry.hs +++ b/src/Pantry.hs @@ -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 diff --git a/src/Pantry/Archive.hs b/src/Pantry/Archive.hs --- a/src/Pantry/Archive.hs +++ b/src/Pantry/Archive.hs @@ -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 diff --git a/src/Pantry/Hackage.hs b/src/Pantry/Hackage.hs --- a/src/Pantry/Hackage.hs +++ b/src/Pantry/Hackage.hs @@ -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 } diff --git a/src/Pantry/Internal/Stackage.hs b/src/Pantry/Internal/Stackage.hs --- a/src/Pantry/Internal/Stackage.hs +++ b/src/Pantry/Internal/Stackage.hs @@ -21,6 +21,7 @@ , TreeId , Unique(..) , Version + , versionVersion , VersionId , getBlobKey , getPackageNameById diff --git a/src/Pantry/Storage.hs b/src/Pantry/Storage.hs --- a/src/Pantry/Storage.hs +++ b/src/Pantry/Storage.hs @@ -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