diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +# 0.1.0.3 + +* When available, use the [all-cabal-hashes](https://github.com/commercialhaskell/all-cabal-hashes) repository for package hash and size verification. + # 0.1.0.2 * Revert back to `cabal install --dry-run` [#2](https://github.com/fpco/stackage-install/issues/2) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -17,6 +17,22 @@ 2. Download the relevant packages from S3, and place them in the locations that `cabal-install` expects 3. Run `cabal install ...` +## Security + +In addition to using HTTPS for download, `stackage-install` can use features of +the [all-cabal-hashes](https://github.com/commercialhaskell/all-cabal-hashes) +repository for extra guarantees. In particular, if you have appropriate data in +your package index (see next paragraph), `stackage-install` will automatically +verify both the hash of the package contents and the download size. If the +server attempts to send more data than expected, the download will be +terminated. + +The easiest way to get this extra data into your package index is to use +[stackage-update](https://github.com/fpco/stackage-update) with the `--hashes` +option. See [hash +downloads](https://github.com/fpco/stackage-update#hash-downloads) for more +information. + ## Caveats If you have a modified `remote-repo` in your ~/.cabal/config file, this tool @@ -37,8 +53,8 @@ The output from `cabal install --dry-run` doesn't actually give us information on which packages need to be downloaded, only the packages to be installed. This will be different in the case of local packages. Unfortunately, `cabal -fetch` won't work for us either, since it accepts different arguments [see -#2](https://github.com/fpco/stackage-install/issues/2). The compromise we have +fetch` won't work for us either, since it accepts different arguments [see #2](https://github.com/fpco/stackage-install/issues/2). +The compromise we have now is to just continue working in the presence of errors during download, though a more robust solution would be to check if one of the arguments refers to a local package. diff --git a/Stackage/Install.hs b/Stackage/Install.hs --- a/Stackage/Install.hs +++ b/Stackage/Install.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} -- | Functionality for downloading packages securely for cabal's usage. module Stackage.Install ( install @@ -7,16 +9,35 @@ , defaultSettings ) where -import Control.Applicative ((*>)) +import qualified Codec.Archive.Tar as Tar +import Control.Applicative ((*>), (<$>), (<*>)) +import Control.Concurrent.Async (wait, withAsync) import Control.Concurrent.Async (Concurrently (..)) import Control.Concurrent.STM (atomically, newTVarIO, readTVar, writeTVar) -import Control.Monad (join, unless) +import Control.Exception (Exception, throwIO) +import Control.Monad (join, unless, when) +import Crypto.Hash (Context, Digest, SHA512, + digestToHexByteString, hashFinalize, + hashInit, hashUpdate) +import Data.Aeson (FromJSON (..), decode, withObject, + (.!=), (.:?)) +import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L import qualified Data.Foldable as F import Data.Function (fix) import Data.List (isPrefixOf) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Typeable (Typeable) +import Data.Word (Word64) import Network.HTTP.Client (Manager, brRead, checkStatus, managerResponseTimeout, newManager, parseUrl, responseBody, @@ -28,7 +49,7 @@ getAppUserDataDirectory, renameFile) import System.Exit (ExitCode) import System.FilePath (takeDirectory, (<.>), ()) -import System.IO (IOMode (WriteMode), stdout, +import System.IO (IOMode (ReadMode, WriteMode), stdout, withBinaryFile) import System.Process (rawSystem, readProcess) @@ -90,22 +111,88 @@ , _connections = 8 } +data Package = Package + { packageHashes :: Map Text Text + , packageLocations :: [Text] + , packageSize :: Maybe Word64 + } + deriving Show +instance FromJSON Package where + parseJSON = withObject "Package" $ \o -> Package + <$> o .:? "package-hashes" .!= Map.empty + <*> o .:? "package-locations" .!= [] + <*> o .:? "package-size" + +getPackageInfo :: FilePath -> Set (String, String) -> IO (Map (String, String) Package) +getPackageInfo packageDir pkgs0 = withBinaryFile indexTar ReadMode $ \h -> do + lbs <- L.hGetContents h + loop pkgs0 Map.empty $ Tar.read lbs + where + indexTar = packageDir "00-index.tar" + + loop pkgs m Tar.Done = do + when (not $ Set.null pkgs) $ + putStrLn $ "Warning: packages not found in index: " ++ show (Set.toList pkgs) + return m + loop _ m (Tar.Fail e) = throwIO $ Couldn'tReadIndexTarball indexTar e + loop pkgs m (Tar.Next e es) = + case (getName $ Tar.entryPath e, Tar.entryContent e) of + (Just pair, Tar.NormalFile lbs _) + | pair `Set.member` pkgs + , Just p <- decode lbs -> + loop (Set.delete pair pkgs) (Map.insert pair p m) es + _ -> loop pkgs m es + + getName name = + case T.splitOn "/" $ T.pack name of + [pkg, ver, fp] | T.stripSuffix ".json" fp == Just pkg + -> Just (T.unpack pkg, T.unpack ver) + _ -> Nothing + +data StackageInstallException + = Couldn'tReadIndexTarball FilePath Tar.FormatError + | InvalidDownloadSize + { _idsUrl :: String + , _idsExpected :: Word64 + , _idsTotalDownloaded :: Word64 + } + | InvalidHash + { _ihUrl :: String + , _ihExpected :: Text + , _ihActual :: Digest SHA512 + } + deriving (Show, Typeable) +instance Exception StackageInstallException + -- | Download the given name,version pairs into the directory expected by cabal. -- -- Since 0.1.0.0 download :: F.Foldable f => Settings -> f (String, String) -> IO () download s pkgs = do - man <- _getManager s cabalDir <- getAppUserDataDirectory "cabal" - parMapM_ (_connections s) (go cabalDir man) pkgs + let packageDir = cabalDir "packages" "hackage.haskell.org" + withAsync (getPackageInfo packageDir $ Set.fromList $ F.toList pkgs) $ \a -> do + man <- _getManager s + parMapM_ (_connections s) (go packageDir man (wait a)) pkgs where unlessM p f = do p' <- p unless p' f - go cabalDir man (name, version) = do + go packageDir man getPackageInfo pair@(name, version) = do unlessM (doesFileExist fp) $ do _onDownload s pkg + packageInfo <- getPackageInfo + let (msha512, url, msize) = + case Map.lookup pair packageInfo of + Nothing -> (Nothing, defUrl, Nothing) + Just p -> + ( Map.lookup "SHA512" $ packageHashes p + , case reverse $ packageLocations p of + [] -> defUrl + x:_ -> T.unpack x + , packageSize p + ) createDirectoryIfMissing True $ takeDirectory fp req <- parseUrl url let req' = req @@ -118,23 +205,55 @@ withResponse req' man $ \res -> if statusCode (responseStatus res) == 200 then do let tmp = fp <.> "tmp" - withBinaryFile tmp WriteMode $ \h -> fix $ \loop -> do - bs <- brRead $ responseBody res - unless (S.null bs) $ do - S.hPut h bs - loop + withBinaryFile tmp WriteMode $ \h -> do + let loop total ctx = do + bs <- brRead $ responseBody res + if S.null bs + then + case msize of + Nothing -> return () + Just expected + | expected /= total -> + throwIO InvalidDownloadSize + { _idsUrl = url + , _idsExpected = expected + , _idsTotalDownloaded = total + } + | otherwise -> validHash url msha512 ctx + else do + S.hPut h bs + let total' = total + fromIntegral (S.length bs) + case msize of + Just expected | expected < total' -> + throwIO InvalidDownloadSize + { _idsUrl = url + , _idsExpected = expected + , _idsTotalDownloaded = total' + } + _ -> loop total' $! hashUpdate ctx bs + loop 0 hashInit renameFile tmp fp else _onDownloadErr s pkg where pkg = concat [name, "-", version] targz = pkg ++ ".tar.gz" - url = _downloadPrefix s ++ targz - fp = cabalDir - "packages" - "hackage.haskell.org" + defUrl = _downloadPrefix s ++ targz + fp = packageDir name version targz + +validHash :: String -> Maybe Text -> Context SHA512 -> IO () +validHash _ Nothing _ = return () +validHash url (Just sha512) ctx + | encodeUtf8 sha512 == digestToHexByteString dig = return () + | otherwise = throwIO InvalidHash + { _ihUrl = url + , _ihExpected = sha512 + , _ihActual = dig + } + where + dig = hashFinalize ctx parMapM_ :: F.Foldable f => Int diff --git a/stackage-install.cabal b/stackage-install.cabal --- a/stackage-install.cabal +++ b/stackage-install.cabal @@ -1,5 +1,5 @@ name: stackage-install -version: 0.1.0.2 +version: 0.1.0.3 synopsis: Secure download of packages for cabal-install description: For more information, see homepage: https://github.com/fpco/stackage-install @@ -24,6 +24,11 @@ , async , stm , http-types + , tar + , containers + , aeson + , cryptohash + , text default-language: Haskell2010 executable stackage-install