Commit 352f5795 authored by Duncan Coutts's avatar Duncan Coutts Committed by Mikhail Glushenkov
Browse files

Add new style project planning

This implements the planning phase of the new nix-style package build and
install system. In particular it includes the calculation of the
nix-style package ids by hashing all the package configuration.

Project planning is separated from project building.

The planning phase starts with finding the packages in the project and
then solving. We solve without looking at the installed packages in the
store. This makes everything more deterministic. The only installed
packages the solver looks at are the globally installed ones. This
approach also means we don't have any need of solver options like
--reinstall or --avoid-reinstalls etc.

The bulk of the planning phase is elaboration. We take the project
configuration and the solver's InstallPlan and elaborate the latter into
an ElaboratedInstallPlan. This is intended to contain all the details
needed for the build phase. For example all the "setup" command flags
are calculated directly from the elaborated plan.

The building phase is then intended to be much simpler and free of much
logic or policy. All of the complicated logic and policy is supposed to
be in the planning phase. This should also make things a lot easier to
debug, we can look at the plan we calculate and see if we're producing
the right build instructions, rather than debugging based on the actions
we end up executing.

Doing all the planning up front is also crucial to calculating nix-style
package hashes. This means we have the package ids up front. This then
allows us to have another up-front phase where we improve the plan by
replacing source packages with installed packages from the store.

All of this stuff is done in the Rebuild monad, with a few levels of
caches, so most of the time we can avoid recomputing the plan. In
particular we want to avoid re-running the solver unless we have to.

There are still quite a number of TODOs, which are categorised.

(cherry picked from commit 2d065c8c)
parent 692d8bf4
......@@ -22,11 +22,15 @@ module Distribution.Client.InstallPlan (
-- * Operations on 'InstallPlan's
......@@ -72,7 +76,7 @@ import Distribution.Text
( display )
import Data.List
( intercalate )
( foldl', intercalate )
import Data.Maybe
( fromMaybe, maybeToList )
import qualified Data.Graph as Graph
......@@ -487,6 +491,79 @@ checkConfiguredPackage (Failed _ _) = Nothing
checkConfiguredPackage pkg =
internalError $ "not configured or no such pkg " ++ display (packageId pkg)
-- | Replace a ready package with a pre-existing one. The pre-existing one
-- must have exactly the same dependencies as the source one was configured
-- with.
preexisting :: (HasUnitId ipkg, PackageFixedDeps ipkg,
HasUnitId srcpkg, PackageFixedDeps srcpkg)
=> UnitId
-> ipkg
-> GenericInstallPlan ipkg srcpkg iresult ifailure
-> GenericInstallPlan ipkg srcpkg iresult ifailure
preexisting pkgid ipkg plan = assert (invariant plan') plan'
plan' = plan {
-- NB: installation can change the IPID, so better
-- record it in the fake mapping...
planFakeMap = Map.insert pkgid
(installedUnitId ipkg)
(planFakeMap plan),
planIndex = PackageIndex.insert (PreExisting ipkg)
-- ...but be sure to use the *old* IPID for the lookup for
-- the preexisting record
. PackageIndex.deleteUnitId pkgid
$ planIndex plan
-- | Transform an install plan by mapping a function over all the packages in
-- the plan. It can consistently change the 'UnitId' of all the packages,
-- while preserving the same overall graph structure.
-- The mapping function has a few constraints on it for correct operation.
-- The mapping function /may/ change the 'UnitId' of the package, but it
-- /must/ also remap the 'UnitId's of its dependencies using ths supplied
-- remapping function. Apart from this consistent remapping it /may not/
-- change the structure of the dependencies.
mapPreservingGraph :: (HasUnitId ipkg,
HasUnitId srcpkg,
HasUnitId ipkg', PackageFixedDeps ipkg',
HasUnitId srcpkg', PackageFixedDeps srcpkg')
=> ( (UnitId -> UnitId)
-> GenericPlanPackage ipkg srcpkg iresult ifailure
-> GenericPlanPackage ipkg' srcpkg' iresult' ifailure')
-> GenericInstallPlan ipkg srcpkg iresult ifailure
-> GenericInstallPlan ipkg' srcpkg' iresult' ifailure'
mapPreservingGraph f plan =
mkInstallPlan (PackageIndex.fromList pkgs')
Map.empty -- empty fakeMap
(planIndepGoals plan)
-- The package mapping function may change the UnitId. So we
-- walk over the packages in dependency order keeping track of these
-- package id changes and use it to supply the correct set of package
-- dependencies as an extra input to the package mapping function.
-- Having fully remapped all the deps this also means we can use an empty
-- FakeMap for the resulting install plan.
(_, pkgs') = foldl' f' (Map.empty, []) (reverseTopologicalOrder plan)
f' (ipkgidMap, pkgs) pkg = (ipkgidMap', pkg' : pkgs)
pkg' = f (mapDep ipkgidMap) pkg
| ipkgid /= ipkgid' = Map.insert ipkgid ipkgid' ipkgidMap
| otherwise = ipkgidMap
ipkgid = installedUnitId pkg
ipkgid' = installedUnitId pkg'
mapDep ipkgidMap ipkgid = Map.findWithDefault ipkgid ipkgid ipkgidMap
-- ------------------------------------------------------------
-- * Checking validity of plans
-- ------------------------------------------------------------
{-# LANGUAGE RecordWildCards, NamedFieldPuns, GeneralizedNewtypeDeriving #-}
-- | Functions to calculate nix-style hashes for package ids.
-- The basic idea is simple, hash the combination of:
-- * the package tarball
-- * the ids of all the direct dependencies
-- * other local configuration (flags, profiling, etc)
module Distribution.Client.PackageHash (
-- * Calculating package hashes
-- * Low level hash choice
) where
import Distribution.Package
( PackageId, mkUnitId )
import Distribution.System
( Platform )
import Distribution.PackageDescription
( FlagName(..), FlagAssignment )
import Distribution.Simple.Compiler
( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)
, ProfDetailLevel(..), showProfDetailLevel )
import Distribution.Simple.InstallDirs
( PathTemplate, fromPathTemplate )
import Distribution.Text
( display )
import Distribution.Client.Types
( InstalledPackageId )
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Crypto.Hash as Hash
import qualified Data.Byteable as Hash
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Maybe (catMaybes)
import Data.List (sortBy, intercalate)
import Data.Function (on)
import Distribution.Compat.Binary (Binary(..))
import Control.Exception (evaluate)
import System.IO (withBinaryFile, IOMode(..))
-- Calculating package hashes
-- | Calculate a 'InstalledPackageId' for a package using our nix-style
-- inputs hashing method.
hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId
hashedInstalledPackageId pkghashinputs@PackageHashInputs{pkgHashPkgId} =
mkUnitId $
display pkgHashPkgId -- to be a bit user friendly
++ "-"
++ showHashValue (hashPackageHashInputs pkghashinputs)
-- | All the information that contribues to a package's hash, and thus its
-- 'InstalledPackageId'.
data PackageHashInputs = PackageHashInputs {
pkgHashPkgId :: PackageId,
pkgHashSourceHash :: PackageSourceHash,
pkgHashDirectDeps :: Set InstalledPackageId,
pkgHashOtherConfig :: PackageHashConfigInputs
type PackageSourceHash = HashValue
-- | Those parts of the package configuration that contribute to the
-- package hash.
data PackageHashConfigInputs = PackageHashConfigInputs {
pkgHashCompilerId :: CompilerId,
pkgHashPlatform :: Platform,
pkgHashFlagAssignment :: FlagAssignment, -- complete not partial
pkgHashConfigureScriptArgs :: [String], -- just ./configure for build-type Configure
pkgHashVanillaLib :: Bool,
pkgHashSharedLib :: Bool,
pkgHashDynExe :: Bool,
pkgHashGHCiLib :: Bool,
pkgHashProfLib :: Bool,
pkgHashProfExe :: Bool,
pkgHashProfLibDetail :: ProfDetailLevel,
pkgHashProfExeDetail :: ProfDetailLevel,
pkgHashCoverage :: Bool,
pkgHashOptimization :: OptimisationLevel,
pkgHashSplitObjs :: Bool,
pkgHashStripLibs :: Bool,
pkgHashStripExes :: Bool,
pkgHashDebugInfo :: DebugInfoLevel,
pkgHashExtraLibDirs :: [FilePath],
pkgHashExtraFrameworkDirs :: [FilePath],
pkgHashExtraIncludeDirs :: [FilePath],
pkgHashProgPrefix :: Maybe PathTemplate,
pkgHashProgSuffix :: Maybe PathTemplate
-- TODO: [required eventually] pkgHashToolsVersions ?
-- TODO: [required eventually] pkgHashToolsExtraOptions ?
-- TODO: [research required] and what about docs?
deriving Show
-- | Calculate the overall hash to be used for an 'InstalledPackageId'.
hashPackageHashInputs :: PackageHashInputs -> HashValue
hashPackageHashInputs = hashValue . renderPackageHashInputs
-- | Render a textual representation of the 'PackageHashInputs'.
-- The 'hashValue' of this text is the overall package hash.
renderPackageHashInputs :: PackageHashInputs -> LBS.ByteString
renderPackageHashInputs PackageHashInputs{
pkgHashOtherConfig =
} =
-- The purpose of this somewhat laboured rendering (e.g. why not just
-- use show?) is so that existing package hashes do not change
-- unnecessarily when new configuration inputs are added into the hash.
-- In particular, the assumption is that when a new configuration input
-- is included into the hash, that existing packages will typically get
-- the default value for that feature. So if we avoid adding entries with
-- the default value then most of the time adding new features will not
-- change the hashes of existing packages and so fewer packages will need
-- to be rebuilt.
--TODO: [nice to have] ultimately we probably want to put this config info
-- into the ghc-pkg db. At that point this should probably be changed to
-- use the config file infrastructure so it can be read back in again.
LBS.pack $ unlines $ catMaybes
[ entry "pkgid" display pkgHashPkgId
, entry "src" showHashValue pkgHashSourceHash
, entry "deps" (intercalate ", " . map display
. Set.toList) pkgHashDirectDeps
-- and then all the config
, entry "compilerid" display pkgHashCompilerId
, entry "platform" display pkgHashPlatform
, opt "flags" [] showFlagAssignment pkgHashFlagAssignment
, opt "configure-script" [] unwords pkgHashConfigureScriptArgs
, opt "vanilla-lib" True display pkgHashVanillaLib
, opt "shared-lib" False display pkgHashSharedLib
, opt "dynamic-exe" False display pkgHashDynExe
, opt "ghci-lib" False display pkgHashGHCiLib
, opt "prof-lib" False display pkgHashProfLib
, opt "prof-exe" False display pkgHashProfExe
, opt "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail
, opt "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail
, opt "hpc" False display pkgHashCoverage
, opt "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization
, opt "split-objs" False display pkgHashSplitObjs
, opt "stripped-lib" False display pkgHashStripLibs
, opt "stripped-exe" True display pkgHashStripExes
, opt "debug-info" NormalDebugInfo (show . fromEnum) pkgHashDebugInfo
, opt "extra-lib-dirs" [] unwords pkgHashExtraLibDirs
, opt "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs
, opt "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs
, opt "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix
, opt "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix
entry key format value = Just (key ++ ": " ++ format value)
opt key def format value
| value == def = Nothing
| otherwise = entry key format value
showFlagAssignment = unwords . map showEntry . sortBy (compare `on` fst)
showEntry (FlagName name, False) = '-' : name
showEntry (FlagName name, True) = '+' : name
-- The specific choice of hash implementation
-- Is a crypto hash necessary here? One thing to consider is who controls the
-- inputs and what's the result of a hash collision. Obviously we should not
-- install packages we don't trust because they can run all sorts of code, but
-- if I've checked there's no TH, no custom Setup etc, is there still a
-- problem? If someone provided us a tarball that hashed to the same value as
-- some other package and we installed it, we could end up re-using that
-- installed package in place of another one we wanted. So yes, in general
-- there is some value in preventing intentional hash collisions in installed
-- package ids.
newtype HashValue = HashValue (Hash.Digest Hash.SHA256)
deriving (Eq, Show)
instance Binary HashValue where
put (HashValue digest) = put (Hash.toBytes digest)
get = do
bs <- get
case Hash.digestFromByteString bs of
Nothing -> fail "HashValue: bad digest"
Just digest -> return (HashValue digest)
hashValue :: LBS.ByteString -> HashValue
hashValue = HashValue . Hash.hashlazy
showHashValue :: HashValue -> String
showHashValue (HashValue digest) = BS.unpack (Hash.digestToHexByteString digest)
readFileHashValue :: FilePath -> IO HashValue
readFileHashValue tarball =
withBinaryFile tarball ReadMode $ \hnd ->
evaluate . hashValue =<< LBS.hGetContents hnd
This diff is collapsed.
......@@ -147,6 +147,12 @@ instance Binary ConfiguredId
instance Show ConfiguredId where
show = show . confSrcId
instance Package ConfiguredId where
packageId = confSrcId
instance HasUnitId ConfiguredId where
installedUnitId = confInstId
instance Package (ConfiguredPackage loc) where
packageId (ConfiguredPackage pkg _ _ _) = packageId pkg
......@@ -69,8 +69,7 @@ import qualified Distribution.Client.List as List
--TODO: temporary import, just to force these modules to be built.
-- It will be replaced by import of new build command once merged.
import Distribution.Client.RebuildMonad ()
import Distribution.Client.ProjectConfig ()
import Distribution.Client.ProjectPlanning ()
import Distribution.Client.Install (install)
import Distribution.Client.Configure (configure)
......@@ -177,6 +177,7 @@ executable cabal
......@@ -185,6 +186,7 @@ executable cabal
......@@ -218,9 +220,11 @@ executable cabal
array >= 0.4 && < 0.6,
base >= 4.5 && < 5,
binary >= 0.5 && < 0.9,
byteable >= 0.1 && < 0.2,
bytestring >= 0.9 && < 1,
Cabal >= 1.25 && < 1.26,
containers >= 0.4 && < 0.6,
cryptohash >= 0.11 && < 0.12,
filepath >= 1.3 && < 1.5,
hashable >= 1.0 && < 2,
HTTP >= 4000.1.5 && < 4000.4,
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment