From ffc915458bb74116cd836314cb2a8fd3dfa06386 Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Thu, 12 Mar 2020 00:24:03 +0200
Subject: [PATCH] fetchAndReadSourcePackageRemoteTarball checks sha256 if
 present.

We can write URIs with a fragment like

    https://hackage.haskell.org/package/cabal-fmt-0.1.2/cabal-fmt-0.1.2.tar.gz#sha256=aae556efbcaddfd65c6a1c1811b122b0d8c8d00624c8c2e36aabb5e9f9ea9840

and fetchAndReadSourcePackageRemoteTarball will check the hash after
download before continuing.
---
 .../Distribution/Client/ProjectConfig.hs      | 37 ++++++++++++++++++-
 1 file changed, 36 insertions(+), 1 deletion(-)

diff --git a/cabal-install/Distribution/Client/ProjectConfig.hs b/cabal-install/Distribution/Client/ProjectConfig.hs
index 234c5f13395..462978cc6b8 100644
--- a/cabal-install/Distribution/Client/ProjectConfig.hs
+++ b/cabal-install/Distribution/Client/ProjectConfig.hs
@@ -121,6 +121,7 @@ import Distribution.Simple.Utils
          ( die', warn, notice, info, createDirectoryIfMissingVerbose )
 import Distribution.Client.Utils
          ( determineNumJobs )
+import Distribution.Parsec (explicitEitherParsec)
 import Distribution.Utils.NubList
          ( fromNubList )
 import Distribution.Verbosity
@@ -141,6 +142,7 @@ import Control.Monad.Trans (liftIO)
 import Control.Exception
 import Data.Either
 import qualified Data.ByteString       as BS
+import qualified Data.ByteString.Char8 as BS8
 import qualified Data.ByteString.Lazy  as LBS
 import qualified Data.Map as Map
 import qualified Data.List.NonEmpty as NE
@@ -155,6 +157,9 @@ import System.Directory
 import Network.URI
          ( URI(..), URIAuth(..), parseAbsoluteURI, uriToString )
 
+import qualified Crypto.Hash.SHA256         as SHA256
+import qualified Data.ByteString.Base16     as Base16
+import qualified Distribution.Compat.CharParsing as P
 
 ----------------------------------------
 -- Resolving configuration to settings
@@ -1099,7 +1104,7 @@ fetchAndReadSourcePackageRemoteTarball verbosity
                                          distDownloadSrcDirectory
                                        }
                                        getTransport
-                                       tarballUri =
+                                       origTarballUri =
     -- The tarball download is expensive so we use another layer of file
     -- monitor to avoid it whenever possible.
     rerunIfChanged verbosity monitor tarballUri $ do
@@ -1109,9 +1114,29 @@ fetchAndReadSourcePackageRemoteTarball verbosity
       liftIO $ do
         transportCheckHttps verbosity transport tarballUri
         notice verbosity ("Downloading " ++ show tarballUri)
+
+        sha256expected <-
+          if null (uriFragment origTarballUri)
+          then return Nothing
+          else case msha256expected of
+            Right hash -> return (Just hash)
+            Left err -> die' verbosity $
+                "Cannot parse URI fragment " ++ uriFragment origTarballUri ++
+                " " ++ err
         createDirectoryIfMissingVerbose verbosity True
                                         distDownloadSrcDirectory
         _ <- downloadURI transport verbosity tarballUri tarballFile
+
+        for_ sha256expected $ \expected -> do
+          contents <- LBS.readFile tarballFile
+          let actual = SHA256.hashlazy contents
+          unless (expected == actual) $
+            die' verbosity $ unwords
+              [ "SHA256 doesn't match for", show tarballUri
+              , "expected", BS8.unpack (Base16.encode expected)
+              , "actual", BS8.unpack (Base16.encode actual)
+              ]
+
         return ()
 
       -- Read
@@ -1121,10 +1146,20 @@ fetchAndReadSourcePackageRemoteTarball verbosity
              . uncurry (readSourcePackageCabalFile verbosity)
            =<< extractTarballPackageCabalFile tarballFile
   where
+    tarballUri = origTarballUri { uriFragment = "" }
+
     tarballStem = distDownloadSrcDirectory
               </> localFileNameForRemoteTarball tarballUri
     tarballFile = tarballStem <.> "tar.gz"
 
+    msha256expected :: Either String BS.ByteString
+    msha256expected = explicitEitherParsec fragmentParser (uriFragment origTarballUri)
+
+    fragmentParser = do
+        _ <- P.string "#sha256="
+        str <- some P.hexDigit
+        return (fst (Base16.decode (BS8.pack str)))
+
     monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
     monitor = newFileMonitor (tarballStem <.> "cache")