redownload pkgs when source hash verification fails (#8500)

* redownload pkgs when source hash verification fails

* changelog

* catch stray io errors reading index

* cleanup TODO

* Update changelog.d/pr-8500

Co-authored-by: Hécate Moonlight <[email protected]>

* fix 9.4.2 build

Co-authored-by: Gershom Bazerman <[email protected]>
Co-authored-by: Hécate Moonlight <[email protected]>
Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>

Author: 3 people

cabal-install/src/Distribution/Client/FetchUtils.hs

@@ -11,7 +11,7 @@
 --
 -- Functions for fetching packages
 -----------------------------------------------------------------------------
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}
 module Distribution.Client.FetchUtils (
 
     -- * fetching packages
@@ -22,6 +22,7 @@ module Distribution.Client.FetchUtils (
     -- ** specifically for repo packages
     checkRepoTarballFetched,
     fetchRepoTarball,
+    verifyFetchedTarball,
 
     -- ** fetching packages asynchronously
     asyncFetchPackages,
@@ -43,7 +44,7 @@ import Distribution.Client.HttpUtils
 import Distribution.Package
          ( PackageId, packageName, packageVersion )
 import Distribution.Simple.Utils
-         ( notice, info, debug, die' )
+         ( notice, info, debug, warn, die' )
 import Distribution.Verbosity
          ( verboseUnmarkOutput )
 import Distribution.Client.GlobalFlags
@@ -56,7 +57,8 @@ import qualified Control.Exception.Safe as Safe
 import Control.Concurrent.Async
 import Control.Concurrent.MVar
 import System.Directory
-         ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )
+         ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory
+         , getFileSize )
 import System.IO
          ( openTempFile, hClose )
 import System.FilePath
@@ -67,6 +69,8 @@ import Network.URI
          ( URI(uriPath) )
 
 import qualified Hackage.Security.Client as Sec
+import qualified Hackage.Security.Util.Path as Sec
+import qualified Hackage.Security.Util.Checked as Sec
 
 -- ------------------------------------------------------------
 -- * Actually fetch things
@@ -118,6 +122,34 @@ checkRepoTarballFetched repo pkgid = do
       then return (Just file)
       else return Nothing
 
+verifyFetchedTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO Bool
+verifyFetchedTarball verbosity repoCtxt repo pkgid =
+   let file = packageFile repo pkgid
+       handleError :: IO Bool -> IO Bool
+       handleError act = do
+         res <- Safe.try act
+         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")
+                       `Sec.catchChecked` (\(e :: Sec.InvalidPackageException) -> warnAndFail (show e))
+                       `Sec.catchChecked` (\(e :: Sec.VerificationError) -> warnAndFail (show e))
+           _ -> pure True
 
 -- | Fetch a package if we don't have it already.
 --

cabal-install/src/Distribution/Client/ProjectPlanning.hs

@@ -170,7 +170,7 @@ import           Text.PrettyPrint (text, hang, quotes, colon, vcat, ($$), fsep,
 import qualified Text.PrettyPrint as Disp
 import qualified Data.Map as Map
 import qualified Data.Set as Set
-import           Control.Monad (sequence)
+import           Control.Monad (sequence, forM)
 import           Control.Monad.IO.Class (liftIO)
 import           Control.Monad.State as State (State, execState, runState, state)
 import           Control.Exception (assert)
@@ -924,20 +924,26 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do
         -- Tarballs from repositories, either where the repository provides
         -- hashes as part of the repo metadata, or where we will have to
         -- download and hash the tarball.
-        repoTarballPkgsWithMetadata    :: [(PackageId, Repo)]
+        repoTarballPkgsWithMetadataUnvalidated    :: [(PackageId, Repo)]
         repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)]
-        (repoTarballPkgsWithMetadata,
+        (repoTarballPkgsWithMetadataUnvalidated,
          repoTarballPkgsWithoutMetadata) =
           partitionEithers
           [ case repo of
               RepoSecure{} -> Left  (pkgid, repo)
               _            -> Right (pkgid, repo)
           | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ]
 
+    (repoTarballPkgsWithMetadata, repoTarballPkgsToRedownload) <- fmap partitionEithers $
+      liftIO $ withRepoCtx $ \repoctx -> forM repoTarballPkgsWithMetadataUnvalidated $
+        \x@(pkg, repo) -> verifyFetchedTarball verbosity repoctx repo pkg >>= \b -> case b of
+                          True -> return $ Left x
+                          False -> return $ Right x
+
     -- For tarballs from repos that do not have hashes available we now have
     -- to check if the packages were downloaded already.
     --
-    (repoTarballPkgsToDownload,
+    (repoTarballPkgsToDownload',
      repoTarballPkgsDownloaded)
       <- fmap partitionEithers $
          liftIO $ sequence
@@ -947,6 +953,7 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do
                   Just tarball -> return (Right (pkgid, tarball))
            | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ]
 
+    let repoTarballPkgsToDownload = repoTarballPkgsToRedownload ++ repoTarballPkgsToDownload'
     (hashesFromRepoMetadata,
      repoTarballPkgsNewlyDownloaded) <-
       -- Avoid having to initialise the repository (ie 'withRepoCtx') if we

changelog.d/pr-8500

@@ -0,0 +1,10 @@
+synopsis: Redownload pkgs when source hash verification fails
+packages: cabal-install
+prs: #8500
+issues: #7541
+
+description: {
+
+- Cabal-install will verify source hashes on cached downloads against the current index, and redownload on mismatch. (Which can occur with e.g. head.hackage)
+
+}