hackport-0.5.1: cabal/cabal-install/Distribution/Client/InstallPlan.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.InstallPlan
-- Copyright : (c) Duncan Coutts 2008
-- License : BSD-like
--
-- Maintainer : duncan@community.haskell.org
-- Stability : provisional
-- Portability : portable
--
-- Package installation plan
--
-----------------------------------------------------------------------------
module Distribution.Client.InstallPlan (
InstallPlan,
GenericInstallPlan,
PlanPackage,
GenericPlanPackage(..),
IsUnit,
-- * Operations on 'InstallPlan's
new,
toGraph,
toList,
toMap,
keys,
keysSet,
planIndepGoals,
depends,
fromSolverInstallPlan,
fromSolverInstallPlanWithProgress,
configureInstallPlan,
remove,
installed,
lookup,
directDeps,
revDirectDeps,
-- * Traversal
executionOrder,
execute,
BuildOutcomes,
lookupBuildOutcome,
-- ** Traversal helpers
-- $traversal
Processing,
ready,
completed,
failed,
-- * Display
showPlanGraph,
showInstallPlan,
-- * Graph-like operations
reverseTopologicalOrder,
reverseDependencyClosure,
) where
import Distribution.Client.Types hiding (BuildOutcomes)
import qualified Distribution.PackageDescription as PD
import qualified Distribution.Simple.Configure as Configure
import qualified Distribution.Simple.Setup as Cabal
import Distribution.InstalledPackageInfo
( InstalledPackageInfo )
import Distribution.Package
( Package(..)
, HasUnitId(..), UnitId )
import Distribution.Solver.Types.SolverPackage
import Distribution.Client.JobControl
import Distribution.Text
import Text.PrettyPrint
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SolverId
import Distribution.Solver.Types.InstSolverPackage
import Distribution.Utils.LogProgress
-- TODO: Need this when we compute final UnitIds
-- import qualified Distribution.Simple.Configure as Configure
import Data.List
( foldl', intercalate )
import qualified Data.Foldable as Foldable (all)
import Data.Maybe
( fromMaybe, catMaybes )
import qualified Distribution.Compat.Graph as Graph
import Distribution.Compat.Graph (Graph, IsNode(..))
import Distribution.Compat.Binary (Binary(..))
import GHC.Generics
import Data.Typeable
import Control.Monad
import Control.Exception
( assert )
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import Data.Set (Set)
import Prelude hiding (lookup)
-- When cabal tries to install a number of packages, including all their
-- dependencies it has a non-trivial problem to solve.
--
-- The Problem:
--
-- In general we start with a set of installed packages and a set of source
-- packages.
--
-- Installed packages have fixed dependencies. They have already been built and
-- we know exactly what packages they were built against, including their exact
-- versions.
--
-- Source package have somewhat flexible dependencies. They are specified as
-- version ranges, though really they're predicates. To make matters worse they
-- have conditional flexible dependencies. Configuration flags can affect which
-- packages are required and can place additional constraints on their
-- versions.
--
-- These two sets of package can and usually do overlap. There can be installed
-- packages that are also available as source packages which means they could
-- be re-installed if required, though there will also be packages which are
-- not available as source and cannot be re-installed. Very often there will be
-- extra versions available than are installed. Sometimes we may like to prefer
-- installed packages over source ones or perhaps always prefer the latest
-- available version whether installed or not.
--
-- The goal is to calculate an installation plan that is closed, acyclic and
-- consistent and where every configured package is valid.
--
-- An installation plan is a set of packages that are going to be used
-- together. It will consist of a mixture of installed packages and source
-- packages along with their exact version dependencies. An installation plan
-- is closed if for every package in the set, all of its dependencies are
-- also in the set. It is consistent if for every package in the set, all
-- dependencies which target that package have the same version.
-- Note that plans do not necessarily compose. You might have a valid plan for
-- package A and a valid plan for package B. That does not mean the composition
-- is simultaneously valid for A and B. In particular you're most likely to
-- have problems with inconsistent dependencies.
-- On the other hand it is true that every closed sub plan is valid.
-- | Packages in an install plan
--
-- NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage'
-- intentionally have no 'PackageInstalled' instance. `This is important:
-- PackageInstalled returns only library dependencies, but for package that
-- aren't yet installed we know many more kinds of dependencies (setup
-- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on
-- dependencies in cabal-install should consider what to do with these
-- dependencies; if we give a 'PackageInstalled' instance it would be too easy
-- to get this wrong (and, for instance, call graph traversal functions from
-- Cabal rather than from cabal-install). Instead, see 'PackageInstalled'.
data GenericPlanPackage ipkg srcpkg
= PreExisting ipkg
| Configured srcpkg
| Installed srcpkg
deriving (Eq, Show, Generic)
type IsUnit a = (IsNode a, Key a ~ UnitId)
depends :: IsUnit a => a -> [UnitId]
depends = nodeNeighbors
-- NB: Expanded constraint synonym here to avoid undecidable
-- instance errors in GHC 7.8 and earlier.
instance (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId)
=> IsNode (GenericPlanPackage ipkg srcpkg) where
type Key (GenericPlanPackage ipkg srcpkg) = UnitId
nodeKey (PreExisting ipkg) = nodeKey ipkg
nodeKey (Configured spkg) = nodeKey spkg
nodeKey (Installed spkg) = nodeKey spkg
nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg
nodeNeighbors (Configured spkg) = nodeNeighbors spkg
nodeNeighbors (Installed spkg) = nodeNeighbors spkg
instance (Binary ipkg, Binary srcpkg)
=> Binary (GenericPlanPackage ipkg srcpkg)
type PlanPackage = GenericPlanPackage
InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)
instance (Package ipkg, Package srcpkg) =>
Package (GenericPlanPackage ipkg srcpkg) where
packageId (PreExisting ipkg) = packageId ipkg
packageId (Configured spkg) = packageId spkg
packageId (Installed spkg) = packageId spkg
instance (HasUnitId ipkg, HasUnitId srcpkg) =>
HasUnitId
(GenericPlanPackage ipkg srcpkg) where
installedUnitId (PreExisting ipkg) = installedUnitId ipkg
installedUnitId (Configured spkg) = installedUnitId spkg
installedUnitId (Installed spkg) = installedUnitId spkg
instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) =>
HasConfiguredId (GenericPlanPackage ipkg srcpkg) where
configuredId (PreExisting ipkg) = configuredId ipkg
configuredId (Configured spkg) = configuredId spkg
configuredId (Installed spkg) = configuredId spkg
data GenericInstallPlan ipkg srcpkg = GenericInstallPlan {
planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg)),
planIndepGoals :: !IndependentGoals
}
deriving (Typeable)
-- | 'GenericInstallPlan' specialised to most commonly used types.
type InstallPlan = GenericInstallPlan
InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)
-- | Smart constructor that deals with caching the 'Graph' representation.
--
mkInstallPlan :: (IsUnit ipkg, IsUnit srcpkg)
=> String
-> Graph (GenericPlanPackage ipkg srcpkg)
-> IndependentGoals
-> GenericInstallPlan ipkg srcpkg
mkInstallPlan loc graph indepGoals =
assert (valid loc graph)
GenericInstallPlan {
planGraph = graph,
planIndepGoals = indepGoals
}
internalError :: String -> String -> a
internalError loc msg = error $ "internal error in InstallPlan." ++ loc
++ if null msg then "" else ": " ++ msg
instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId,
Binary ipkg, Binary srcpkg)
=> Binary (GenericInstallPlan ipkg srcpkg) where
put GenericInstallPlan {
planGraph = graph,
planIndepGoals = indepGoals
} = put (graph, indepGoals)
get = do
(graph, indepGoals) <- get
return $! mkInstallPlan "(instance Binary)" graph indepGoals
showPlanGraph :: (Package ipkg, Package srcpkg,
IsUnit ipkg, IsUnit srcpkg)
=> Graph (GenericPlanPackage ipkg srcpkg) -> String
showPlanGraph graph = renderStyle defaultStyle $
vcat (map dispPlanPackage (Graph.toList graph))
where dispPlanPackage p =
hang (hsep [ text (showPlanPackageTag p)
, disp (packageId p)
, parens (disp (nodeKey p))]) 2
(vcat (map disp (nodeNeighbors p)))
showInstallPlan :: (Package ipkg, Package srcpkg,
IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg -> String
showInstallPlan = showPlanGraph . planGraph
showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String
showPlanPackageTag (PreExisting _) = "PreExisting"
showPlanPackageTag (Configured _) = "Configured"
showPlanPackageTag (Installed _) = "Installed"
-- | Build an installation plan from a valid set of resolved packages.
--
new :: (IsUnit ipkg, IsUnit srcpkg)
=> IndependentGoals
-> Graph (GenericPlanPackage ipkg srcpkg)
-> GenericInstallPlan ipkg srcpkg
new indepGoals graph = mkInstallPlan "new" graph indepGoals
toGraph :: GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
toGraph = planGraph
toList :: GenericInstallPlan ipkg srcpkg
-> [GenericPlanPackage ipkg srcpkg]
toList = Graph.toList . planGraph
toMap :: GenericInstallPlan ipkg srcpkg
-> Map UnitId (GenericPlanPackage ipkg srcpkg)
toMap = Graph.toMap . planGraph
keys :: GenericInstallPlan ipkg srcpkg -> [UnitId]
keys = Graph.keys . planGraph
keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId
keysSet = Graph.keysSet . planGraph
-- | Remove packages from the install plan. This will result in an
-- error if there are remaining packages that depend on any matching
-- package. This is primarily useful for obtaining an install plan for
-- the dependencies of a package or set of packages without actually
-- installing the package itself, as when doing development.
--
remove :: (IsUnit ipkg, IsUnit srcpkg)
=> (GenericPlanPackage ipkg srcpkg -> Bool)
-> GenericInstallPlan ipkg srcpkg
-> GenericInstallPlan ipkg srcpkg
remove shouldRemove plan =
mkInstallPlan "remove" newGraph (planIndepGoals plan)
where
newGraph = Graph.fromList $
filter (not . shouldRemove) (toList plan)
-- | Change a number of packages in the 'Configured' state to the 'Installed'
-- state.
--
-- To preserve invariants, the package must have all of its dependencies
-- already installed too (that is 'PreExisting' or 'Installed').
--
installed :: (IsUnit ipkg, IsUnit srcpkg)
=> (srcpkg -> Bool)
-> GenericInstallPlan ipkg srcpkg
-> GenericInstallPlan ipkg srcpkg
installed shouldBeInstalled installPlan =
foldl' markInstalled installPlan
[ pkg
| Configured pkg <- reverseTopologicalOrder installPlan
, shouldBeInstalled pkg ]
where
markInstalled plan pkg =
assert (all isInstalled (directDeps plan (nodeKey pkg))) $
plan {
planGraph = Graph.insert (Installed pkg) (planGraph plan)
}
-- | Lookup a package in the plan.
--
lookup :: (IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg
-> UnitId
-> Maybe (GenericPlanPackage ipkg srcpkg)
lookup plan pkgid = Graph.lookup pkgid (planGraph plan)
-- | Find all the direct dependencies of the given package.
--
-- Note that the package must exist in the plan or it is an error.
--
directDeps :: GenericInstallPlan ipkg srcpkg
-> UnitId
-> [GenericPlanPackage ipkg srcpkg]
directDeps plan pkgid =
case Graph.neighbors (planGraph plan) pkgid of
Just deps -> deps
Nothing -> internalError "directDeps" "package not in graph"
-- | Find all the direct reverse dependencies of the given package.
--
-- Note that the package must exist in the plan or it is an error.
--
revDirectDeps :: GenericInstallPlan ipkg srcpkg
-> UnitId
-> [GenericPlanPackage ipkg srcpkg]
revDirectDeps plan pkgid =
case Graph.revNeighbors (planGraph plan) pkgid of
Just deps -> deps
Nothing -> internalError "revDirectDeps" "package not in graph"
-- | Return all the packages in the 'InstallPlan' in reverse topological order.
-- That is, for each package, all dependencies of the package appear first.
--
-- Compared to 'executionOrder', this function returns all the installed and
-- source packages rather than just the source ones. Also, while both this
-- and 'executionOrder' produce reverse topological orderings of the package
-- dependency graph, it is not necessarily exactly the same order.
--
reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg
-> [GenericPlanPackage ipkg srcpkg]
reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan)
-- | Return the packages in the plan that depend directly or indirectly on the
-- given packages.
--
reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg
-> [UnitId]
-> [GenericPlanPackage ipkg srcpkg]
reverseDependencyClosure plan = fromMaybe []
. Graph.revClosure (planGraph plan)
-- Alert alert! Why does SolverId map to a LIST of plan packages?
-- The sordid story has to do with 'build-depends' on a package
-- with libraries and executables. In an ideal world, we would
-- ONLY depend on the library in this situation. But c.f. #3661
-- some people rely on the build-depends to ALSO implicitly
-- depend on an executable.
--
-- I don't want to commit to a strategy yet, so the only possible
-- thing you can do in this case is return EVERYTHING and let
-- the client filter out what they want (executables? libraries?
-- etc). This similarly implies we can't return a 'ConfiguredId'
-- because that's not enough information.
fromSolverInstallPlan ::
(IsUnit ipkg, IsUnit srcpkg)
=> ( (SolverId -> [GenericPlanPackage ipkg srcpkg])
-> SolverInstallPlan.SolverPlanPackage
-> [GenericPlanPackage ipkg srcpkg] )
-> SolverInstallPlan
-> GenericInstallPlan ipkg srcpkg
fromSolverInstallPlan f plan =
mkInstallPlan "fromSolverInstallPlan"
(Graph.fromList pkgs'')
(SolverInstallPlan.planIndepGoals plan)
where
(_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, [])
(SolverInstallPlan.reverseTopologicalOrder plan)
f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs)
where
pkgs' = f (mapDep pidMap ipiMap) pkg
(pidMap', ipiMap')
= case nodeKey pkg of
PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)
PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap)
mapDep _ ipiMap (PreExistingId _pid uid)
| Just pkgs <- Map.lookup uid ipiMap = pkgs
| otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ display uid)
mapDep pidMap _ (PlannedId pid)
| Just pkgs <- Map.lookup pid pidMap = pkgs
| otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display pid)
-- This shouldn't happen, since mapDep should only be called
-- on neighbor SolverId, which must have all been done already
-- by the reverse top-sort (we assume the graph is not broken).
fromSolverInstallPlanWithProgress ::
(IsUnit ipkg, IsUnit srcpkg)
=> ( (SolverId -> [GenericPlanPackage ipkg srcpkg])
-> SolverInstallPlan.SolverPlanPackage
-> LogProgress [GenericPlanPackage ipkg srcpkg] )
-> SolverInstallPlan
-> LogProgress (GenericInstallPlan ipkg srcpkg)
fromSolverInstallPlanWithProgress f plan = do
(_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, [])
(SolverInstallPlan.reverseTopologicalOrder plan)
return $ mkInstallPlan "fromSolverInstallPlanWithProgress"
(Graph.fromList pkgs'')
(SolverInstallPlan.planIndepGoals plan)
where
f' (pidMap, ipiMap, pkgs) pkg = do
pkgs' <- f (mapDep pidMap ipiMap) pkg
let (pidMap', ipiMap')
= case nodeKey pkg of
PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)
PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap)
return (pidMap', ipiMap', pkgs' ++ pkgs)
mapDep _ ipiMap (PreExistingId _pid uid)
| Just pkgs <- Map.lookup uid ipiMap = pkgs
| otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ display uid)
mapDep pidMap _ (PlannedId pid)
| Just pkgs <- Map.lookup pid pidMap = pkgs
| otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display pid)
-- This shouldn't happen, since mapDep should only be called
-- on neighbor SolverId, which must have all been done already
-- by the reverse top-sort (we assume the graph is not broken).
-- | Conversion of 'SolverInstallPlan' to 'InstallPlan'.
-- Similar to 'elaboratedInstallPlan'
configureInstallPlan :: SolverInstallPlan -> InstallPlan
configureInstallPlan solverPlan =
flip fromSolverInstallPlan solverPlan $ \mapDep planpkg ->
[case planpkg of
SolverInstallPlan.PreExisting pkg ->
PreExisting (instSolverPkgIPI pkg)
SolverInstallPlan.Configured pkg ->
Configured (configureSolverPackage mapDep pkg)
]
where
configureSolverPackage :: (SolverId -> [PlanPackage])
-> SolverPackage UnresolvedPkgLoc
-> ConfiguredPackage UnresolvedPkgLoc
configureSolverPackage mapDep spkg =
ConfiguredPackage {
confPkgId = Configure.computeComponentId
Cabal.NoFlag
Cabal.NoFlag
(packageId spkg)
PD.CLibName
(Just (map confInstId (CD.libraryDeps deps),
solverPkgFlags spkg)),
confPkgSource = solverPkgSource spkg,
confPkgFlags = solverPkgFlags spkg,
confPkgStanzas = solverPkgStanzas spkg,
confPkgDeps = deps
-- NB: no support for executable dependencies
}
where
deps = fmap (concatMap (map configuredId . mapDep)) (solverPkgLibDeps spkg)
-- ------------------------------------------------------------
-- * Primitives for traversing plans
-- ------------------------------------------------------------
-- $traversal
--
-- Algorithms to traverse or execute an 'InstallPlan', especially in parallel,
-- may make use of the 'Processing' type and the associated operations
-- 'ready', 'completed' and 'failed'.
--
-- The 'Processing' type is used to keep track of the state of a traversal and
-- includes the set of packages that are in the processing state, e.g. in the
-- process of being installed, plus those that have been completed and those
-- where processing failed.
--
-- Traversal algorithms start with an 'InstallPlan':
--
-- * Initially there will be certain packages that can be processed immediately
-- (since they are configured source packages and have all their dependencies
-- installed already). The function 'ready' returns these packages plus a
-- 'Processing' state that marks these same packages as being in the
-- processing state.
--
-- * The algorithm must now arrange for these packages to be processed
-- (possibly in parallel). When a package has completed processing, the
-- algorithm needs to know which other packages (if any) are now ready to
-- process as a result. The 'completed' function marks a package as completed
-- and returns any packages that are newly in the processing state (ie ready
-- to process), along with the updated 'Processing' state.
--
-- * If failure is possible then when processing a package fails, the algorithm
-- needs to know which other packages have also failed as a result. The
-- 'failed' function marks the given package as failed as well as all the
-- other packages that depend on the failed package. In addition it returns
-- the other failed packages.
-- | The 'Processing' type is used to keep track of the state of a traversal
-- and includes the set of packages that are in the processing state, e.g. in
-- the process of being installed, plus those that have been completed and
-- those where processing failed.
--
data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId)
-- processing, completed, failed
-- | The packages in the plan that are initially ready to be installed.
-- That is they are in the configured state and have all their dependencies
-- installed already.
--
-- The result is both the packages that are now ready to be installed and also
-- a 'Processing' state containing those same packages. The assumption is that
-- all the packages that are ready will now be processed and so we can consider
-- them to be in the processing state.
--
ready :: (IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg
-> ([GenericReadyPackage srcpkg], Processing)
ready plan =
assert (processingInvariant plan processing) $
(readyPackages, processing)
where
!processing =
Processing
(Set.fromList [ nodeKey pkg | pkg <- readyPackages ])
(Set.fromList [ nodeKey pkg | pkg <- toList plan, isInstalled pkg ])
Set.empty
readyPackages =
[ ReadyPackage pkg
| Configured pkg <- toList plan
, all isInstalled (directDeps plan (nodeKey pkg))
]
isInstalled :: GenericPlanPackage a b -> Bool
isInstalled (PreExisting {}) = True
isInstalled (Installed {}) = True
isInstalled _ = False
-- | Given a package in the processing state, mark the package as completed
-- and return any packages that are newly in the processing state (ie ready to
-- process), along with the updated 'Processing' state.
--
completed :: (IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg
-> Processing -> UnitId
-> ([GenericReadyPackage srcpkg], Processing)
completed plan (Processing processingSet completedSet failedSet) pkgid =
assert (pkgid `Set.member` processingSet) $
assert (processingInvariant plan processing') $
( map asReadyPackage newlyReady
, processing' )
where
completedSet' = Set.insert pkgid completedSet
-- each direct reverse dep where all direct deps are completed
newlyReady = [ dep
| dep <- revDirectDeps plan pkgid
, all ((`Set.member` completedSet') . nodeKey)
(directDeps plan (nodeKey dep))
]
processingSet' = foldl' (flip Set.insert)
(Set.delete pkgid processingSet)
(map nodeKey newlyReady)
processing' = Processing processingSet' completedSet' failedSet
asReadyPackage (Configured pkg) = ReadyPackage pkg
asReadyPackage _ = internalError "completed" ""
failed :: (IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg
-> Processing -> UnitId
-> ([srcpkg], Processing)
failed plan (Processing processingSet completedSet failedSet) pkgid =
assert (pkgid `Set.member` processingSet) $
assert (all (`Set.notMember` processingSet) (tail newlyFailedIds)) $
assert (all (`Set.notMember` completedSet) (tail newlyFailedIds)) $
-- but note that some newlyFailed may already be in the failed set
-- since one package can depend on two packages that both fail and
-- so would be in the rev-dep closure for both.
assert (processingInvariant plan processing') $
( map asConfiguredPackage (tail newlyFailed)
, processing' )
where
processingSet' = Set.delete pkgid processingSet
failedSet' = failedSet `Set.union` Set.fromList newlyFailedIds
newlyFailedIds = map nodeKey newlyFailed
newlyFailed = fromMaybe (internalError "failed" "package not in graph")
$ Graph.revClosure (planGraph plan) [pkgid]
processing' = Processing processingSet' completedSet failedSet'
asConfiguredPackage (Configured pkg) = pkg
asConfiguredPackage _ = internalError "failed" "not in configured state"
processingInvariant :: (IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg
-> Processing -> Bool
processingInvariant plan (Processing processingSet completedSet failedSet) =
-- All the packages in the three sets are actually in the graph
assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet) $
assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet) $
assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet) $
-- The processing, completed and failed sets are disjoint from each other
assert (noIntersection processingSet completedSet) $
assert (noIntersection processingSet failedSet) $
assert (noIntersection failedSet completedSet) $
-- Packages that depend on a package that's still processing cannot be
-- completed
assert (noIntersection (reverseClosure processingSet) completedSet) $
-- On the other hand, packages that depend on a package that's still
-- processing /can/ have failed (since they may have depended on multiple
-- packages that were processing, but it only takes one to fail to cause
-- knock-on failures) so it is quite possible to have an
-- intersection (reverseClosure processingSet) failedSet
-- The failed set is upwards closed, i.e. equal to its own rev dep closure
assert (failedSet == reverseClosure failedSet) $
-- All immediate reverse deps of packges that are currently processing
-- are not currently being processed (ie not in the processing set).
assert (and [ rdeppkgid `Set.notMember` processingSet
| pkgid <- Set.toList processingSet
, rdeppkgid <- maybe (internalError "processingInvariant" "")
(map nodeKey)
(Graph.revNeighbors (planGraph plan) pkgid)
]) $
-- Packages from the processing or failed sets are only ever in the
-- configured state.
assert (and [ case Graph.lookup pkgid (planGraph plan) of
Just (Configured _) -> True
Just (PreExisting _) -> False
Just (Installed _) -> False
Nothing -> False
| pkgid <- Set.toList processingSet ++ Set.toList failedSet ])
-- We use asserts rather than returning False so that on failure we get
-- better details on which bit of the invariant was violated.
True
where
reverseClosure = Set.fromList
. map nodeKey
. fromMaybe (internalError "processingInvariant" "")
. Graph.revClosure (planGraph plan)
. Set.toList
noIntersection a b = Set.null (Set.intersection a b)
-- ------------------------------------------------------------
-- * Traversing plans
-- ------------------------------------------------------------
-- | Flatten an 'InstallPlan', producing the sequence of source packages in
-- the order in which they would be processed when the plan is executed. This
-- can be used for simultations or presenting execution dry-runs.
--
-- It is guaranteed to give the same order as using 'execute' (with a serial
-- in-order 'JobControl'), which is a reverse topological orderings of the
-- source packages in the dependency graph, albeit not necessarily exactly the
-- same ordering as that produced by 'reverseTopologicalOrder'.
--
executionOrder :: (IsUnit ipkg, IsUnit srcpkg)
=> GenericInstallPlan ipkg srcpkg
-> [GenericReadyPackage srcpkg]
executionOrder plan =
let (newpkgs, processing) = ready plan
in tryNewTasks processing newpkgs
where
tryNewTasks _processing [] = []
tryNewTasks processing (p:todo) = waitForTasks processing p todo
waitForTasks processing p todo =
p : tryNewTasks processing' (todo++nextpkgs)
where
(nextpkgs, processing') = completed plan processing (nodeKey p)
-- ------------------------------------------------------------
-- * Executing plans
-- ------------------------------------------------------------
-- | The set of results we get from executing an install plan.
--
type BuildOutcomes failure result = Map UnitId (Either failure result)
-- | Lookup the build result for a single package.
--
lookupBuildOutcome :: HasUnitId pkg
=> pkg -> BuildOutcomes failure result
-> Maybe (Either failure result)
lookupBuildOutcome = Map.lookup . installedUnitId
-- | Execute an install plan. This traverses the plan in dependency order.
--
-- Executing each individual package can fail and if so all dependents fail
-- too. The result for each package is collected as a 'BuildOutcomes' map.
--
-- Visiting each package happens with optional parallelism, as determined by
-- the 'JobControl'. By default, after any failure we stop as soon as possible
-- (using the 'JobControl' to try to cancel in-progress tasks). This behaviour
-- can be reversed to keep going and build as many packages as possible.
--
-- Note that the 'BuildOutcomes' is /not/ guaranteed to cover all the packages
-- in the plan. In particular in the default mode where we stop as soon as
-- possible after a failure then there may be packages which are skipped and
-- these will have no 'BuildOutcome'.
--
execute :: forall m ipkg srcpkg result failure.
(IsUnit ipkg, IsUnit srcpkg,
Monad m)
=> JobControl m (UnitId, Either failure result)
-> Bool -- ^ Keep going after failure
-> (srcpkg -> failure) -- ^ Value for dependents of failed packages
-> GenericInstallPlan ipkg srcpkg
-> (GenericReadyPackage srcpkg -> m (Either failure result))
-> m (BuildOutcomes failure result)
execute jobCtl keepGoing depFailure plan installPkg =
let (newpkgs, processing) = ready plan
in tryNewTasks Map.empty False False processing newpkgs
where
tryNewTasks :: BuildOutcomes failure result
-> Bool -> Bool -> Processing
-> [GenericReadyPackage srcpkg]
-> m (BuildOutcomes failure result)
tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs
-- we were in the process of cancelling and now we're finished
| tasksFailed && not keepGoing && not tasksRemaining
= return results
-- we are still in the process of cancelling, wait for remaining tasks
| tasksFailed && not keepGoing && tasksRemaining
= waitForTasks results tasksFailed processing
-- no new tasks to do and all tasks are done so we're finished
| null newpkgs && not tasksRemaining
= return results
-- no new tasks to do, remaining tasks to wait for
| null newpkgs
= waitForTasks results tasksFailed processing
-- new tasks to do, spawn them, then wait for tasks to complete
| otherwise
= do sequence_ [ spawnJob jobCtl $ do
result <- installPkg pkg
return (nodeKey pkg, result)
| pkg <- newpkgs ]
waitForTasks results tasksFailed processing
waitForTasks :: BuildOutcomes failure result
-> Bool -> Processing
-> m (BuildOutcomes failure result)
waitForTasks !results tasksFailed !processing = do
(pkgid, result) <- collectJob jobCtl
case result of
Right _success -> do
tasksRemaining <- remainingJobs jobCtl
tryNewTasks results' tasksFailed tasksRemaining
processing' nextpkgs
where
results' = Map.insert pkgid result results
(nextpkgs, processing') = completed plan processing pkgid
Left _failure -> do
-- if this is the first failure and we're not trying to keep going
-- then try to cancel as many of the remaining jobs as possible
when (not tasksFailed && not keepGoing) $
cancelJobs jobCtl
tasksRemaining <- remainingJobs jobCtl
tryNewTasks results' True tasksRemaining processing' []
where
(depsfailed, processing') = failed plan processing pkgid
results' = Map.insert pkgid result results `Map.union` depResults
depResults = Map.fromList
[ (nodeKey deppkg, Left (depFailure deppkg))
| deppkg <- depsfailed ]
-- ------------------------------------------------------------
-- * Checking validity of plans
-- ------------------------------------------------------------
-- | A valid installation plan is a set of packages that is closed, acyclic
-- and respects the package state relation.
--
-- * if the result is @False@ use 'problems' to get a detailed list.
--
valid :: (IsUnit ipkg, IsUnit srcpkg)
=> String -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool
valid loc graph =
case problems graph of
[] -> True
ps -> internalError loc ('\n' : unlines (map showPlanProblem ps))
data PlanProblem ipkg srcpkg =
PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [UnitId]
| PackageCycle [GenericPlanPackage ipkg srcpkg]
| PackageStateInvalid (GenericPlanPackage ipkg srcpkg)
(GenericPlanPackage ipkg srcpkg)
showPlanProblem :: (IsUnit ipkg, IsUnit srcpkg)
=> PlanProblem ipkg srcpkg -> String
showPlanProblem (PackageMissingDeps pkg missingDeps) =
"Package " ++ display (nodeKey pkg)
++ " depends on the following packages which are missing from the plan: "
++ intercalate ", " (map display missingDeps)
showPlanProblem (PackageCycle cycleGroup) =
"The following packages are involved in a dependency cycle "
++ intercalate ", " (map (display . nodeKey) cycleGroup)
showPlanProblem (PackageStateInvalid pkg pkg') =
"Package " ++ display (nodeKey pkg)
++ " is in the " ++ showPlanPackageTag pkg
++ " state but it depends on package " ++ display (nodeKey pkg')
++ " which is in the " ++ showPlanPackageTag pkg'
++ " state"
-- | For an invalid plan, produce a detailed list of problems as human readable
-- error messages. This is mainly intended for debugging purposes.
-- Use 'showPlanProblem' for a human readable explanation.
--
problems :: (IsUnit ipkg, IsUnit srcpkg)
=> Graph (GenericPlanPackage ipkg srcpkg)
-> [PlanProblem ipkg srcpkg]
problems graph =
[ PackageMissingDeps pkg
(catMaybes
(map
(fmap nodeKey . flip Graph.lookup graph)
missingDeps))
| (pkg, missingDeps) <- Graph.broken graph ]
++ [ PackageCycle cycleGroup
| cycleGroup <- Graph.cycles graph ]
{-
++ [ PackageInconsistency name inconsistencies
| (name, inconsistencies) <-
dependencyInconsistencies indepGoals graph ]
--TODO: consider re-enabling this one, see SolverInstallPlan
-}
++ [ PackageStateInvalid pkg pkg'
| pkg <- Graph.toList graph
, Just pkg' <- map (flip Graph.lookup graph)
(nodeNeighbors pkg)
, not (stateDependencyRelation pkg pkg') ]
-- | The states of packages have that depend on each other must respect
-- this relation. That is for very case where package @a@ depends on
-- package @b@ we require that @stateDependencyRelation a b = True@.
--
stateDependencyRelation :: GenericPlanPackage ipkg srcpkg
-> GenericPlanPackage ipkg srcpkg -> Bool
stateDependencyRelation PreExisting{} PreExisting{} = True
stateDependencyRelation Installed{} PreExisting{} = True
stateDependencyRelation Installed{} Installed{} = True
stateDependencyRelation Configured{} PreExisting{} = True
stateDependencyRelation Configured{} Installed{} = True
stateDependencyRelation Configured{} Configured{} = True
stateDependencyRelation _ _ = False