Skip to content

Commit

Permalink
fetchAndReadSourcePackageRemoteTarball checks sha256 if present.
Browse files Browse the repository at this point in the history
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.
  • Loading branch information
phadej committed Mar 11, 2020
1 parent f4ecbf1 commit ffc9154
Showing 1 changed file with 36 additions and 1 deletion.
37 changes: 36 additions & 1 deletion cabal-install/Distribution/Client/ProjectConfig.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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")

Expand Down

0 comments on commit ffc9154

Please sign in to comment.