Skip to content

Commit

Permalink
Merge pull request #8697 from haskell/gb/no-warn-missing-tarball-down…
Browse files Browse the repository at this point in the history
…load

elim warning spam from #8500
  • Loading branch information
Mikolaj authored Jan 24, 2023
2 parents 8aad429 + ffa9127 commit 14727bc
Show file tree
Hide file tree
Showing 2 changed files with 24 additions and 20 deletions.
38 changes: 21 additions & 17 deletions cabal-install/src/Distribution/Client/FetchUtils.hs
Original file line number Diff line number Diff line change
Expand Up @@ -131,25 +131,29 @@ verifyFetchedTarball verbosity repoCtxt repo pkgid =
case res of
Left e -> warn verbosity ("Error verifying fetched tarball " ++ file ++ ", will redownload: " ++ show (e :: SomeException)) >> pure False
Right b -> pure b
in handleError $ case repo of
-- a secure repo has hashes we can compare against to confirm this is the correct file.
RepoSecure{} ->
repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->
Sec.withIndex repoSecure $ \callbacks ->
let warnAndFail s = warn verbosity ("Fetched tarball " ++ file ++ " does not match server, will redownload: " ++ s) >> return False
-- the do block in parens is due to dealing with the checked exceptions mechanism.
in (do fileInfo <- Sec.indexLookupFileInfo callbacks pkgid
sz <- Sec.FileLength . fromInteger <$> getFileSize file
if sz /= Sec.fileInfoLength (Sec.trusted fileInfo)
then warnAndFail "file length mismatch"
else do
res <- Sec.compareTrustedFileInfo (Sec.trusted fileInfo) <$> Sec.computeFileInfo (Sec.Path file :: Sec.Path Sec.Absolute)
if res
then pure True
else warnAndFail "file hash mismatch")
in handleError $ do
exists <- doesFileExist file
if not exists
then return False
else case repo of
-- a secure repo has hashes we can compare against to confirm this is the correct file.
RepoSecure{} ->
repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->
Sec.withIndex repoSecure $ \callbacks ->
let warnAndFail s = warn verbosity ("Fetched tarball " ++ file ++ " does not match server, will redownload: " ++ s) >> return False
-- the do block in parens is due to dealing with the checked exceptions mechanism.
in (do fileInfo <- Sec.indexLookupFileInfo callbacks pkgid
sz <- Sec.FileLength . fromInteger <$> getFileSize file
if sz /= Sec.fileInfoLength (Sec.trusted fileInfo)
then warnAndFail "file length mismatch"
else do
res <- Sec.compareTrustedFileInfo (Sec.trusted fileInfo) <$> Sec.computeFileInfo (Sec.Path file :: Sec.Path Sec.Absolute)
if res
then pure True
else warnAndFail "file hash mismatch")
`Sec.catchChecked` (\(e :: Sec.InvalidPackageException) -> warnAndFail (show e))
`Sec.catchChecked` (\(e :: Sec.VerificationError) -> warnAndFail (show e))
_ -> pure True
_ -> pure True

-- | Fetch a package if we don't have it already.
--
Expand Down
6 changes: 3 additions & 3 deletions cabal-install/src/Distribution/Client/ProjectPlanning.hs
Original file line number Diff line number Diff line change
Expand Up @@ -935,7 +935,7 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do
_ -> Right (pkgid, repo)
| (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ]

(repoTarballPkgsWithMetadata, repoTarballPkgsToRedownload) <- fmap partitionEithers $
(repoTarballPkgsWithMetadata, repoTarballPkgsToDownloadWithMeta) <- fmap partitionEithers $
liftIO $ withRepoCtx $ \repoctx -> forM repoTarballPkgsWithMetadataUnvalidated $
\x@(pkg, repo) -> verifyFetchedTarball verbosity repoctx repo pkg >>= \b -> case b of
True -> return $ Left x
Expand All @@ -944,7 +944,7 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do
-- For tarballs from repos that do not have hashes available we now have
-- to check if the packages were downloaded already.
--
(repoTarballPkgsToDownload',
(repoTarballPkgsToDownloadWithNoMeta,
repoTarballPkgsDownloaded)
<- fmap partitionEithers $
liftIO $ sequence
Expand All @@ -954,7 +954,7 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do
Just tarball -> return (Right (pkgid, tarball))
| (pkgid, repo) <- repoTarballPkgsWithoutMetadata ]

let repoTarballPkgsToDownload = repoTarballPkgsToRedownload ++ repoTarballPkgsToDownload'
let repoTarballPkgsToDownload = repoTarballPkgsToDownloadWithMeta ++ repoTarballPkgsToDownloadWithNoMeta
(hashesFromRepoMetadata,
repoTarballPkgsNewlyDownloaded) <-
-- Avoid having to initialise the repository (ie 'withRepoCtx') if we
Expand Down

0 comments on commit 14727bc

Please sign in to comment.