Commit 31be24fa authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Add InstallPlan.execute plus tests

This is intended to replace a couple existing executeInstallPlan
implementations.

The tests check that execute visits packages in reverse topological
order, for both serial and parallel job control. There's also a check
that serial execute and executionOrder use exactly the same order.
parent af112a61
......@@ -39,6 +39,9 @@ module Distribution.Client.InstallPlan (
-- * Traversal
executionOrder,
execute,
BuildResults,
lookupBuildResult,
-- ** Traversal helpers
-- $traversal
Processing,
......@@ -65,6 +68,7 @@ import Distribution.Package
( PackageIdentifier(..), Package(..)
, HasUnitId(..), UnitId(..) )
import Distribution.Solver.Types.SolverPackage
import Distribution.Client.JobControl
import Distribution.Text
( display )
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
......@@ -87,9 +91,11 @@ import qualified Distribution.Compat.Graph as Graph
import Distribution.Compat.Graph (Graph, IsNode(..))
import Distribution.Compat.Binary (Binary(..))
import GHC.Generics
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 qualified Data.Traversable as T
......@@ -844,6 +850,10 @@ processingInvariant plan (Processing' processingSet completedSet failedSet) =
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.
......@@ -868,3 +878,104 @@ executionOrder plan =
p : tryNewTasks processing' (todo++nextpkgs)
where
(nextpkgs, processing') = completed' plan processing (installedUnitId p)
-- ------------------------------------------------------------
-- * Executing plans
-- ------------------------------------------------------------
-- | The set of results we get from executing an install plan.
--
type BuildResults failure result = Map UnitId (Either failure result)
-- | Lookup the build result for a single package.
--
lookupBuildResult :: HasUnitId pkg
=> pkg -> BuildResults failure result
-> Maybe (Either failure result)
lookupBuildResult = 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 'BuildResults' 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.
--
execute :: forall m ipkg srcpkg result failure unused1 unused2.
(HasUnitId ipkg, PackageFixedDeps ipkg,
HasUnitId srcpkg, PackageFixedDeps 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 unused1 unused2
-> (GenericReadyPackage srcpkg -> m (Either failure result))
-> m (BuildResults failure result)
execute jobCtl keepGoing depFailure plan installPkg =
let (newpkgs, processing) = ready' plan
in tryNewTasks Map.empty False False processing newpkgs
where
tryNewTasks :: BuildResults failure result
-> Bool -> Bool -> Processing
-> [GenericReadyPackage srcpkg]
-> m (BuildResults 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 (installedUnitId pkg, result)
| pkg <- newpkgs ]
waitForTasks results tasksFailed processing
waitForTasks :: BuildResults failure result
-> Bool -> Processing
-> m (BuildResults 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
[ (installedUnitId deppkg, Left (depFailure deppkg))
| deppkg <- depsfailed ]
......@@ -8,6 +8,8 @@ import qualified Distribution.Compat.Graph as Graph
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.PackageFixedDeps
import Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Client.Types
import Distribution.Client.JobControl
import Data.Graph
import Data.Array hiding (index)
......@@ -15,7 +17,10 @@ import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Set (Set)
import Data.IORef
import Control.Monad
import Control.Concurrent (threadDelay)
import System.Random
import Test.QuickCheck
import Test.Tasty
......@@ -26,6 +31,9 @@ tests :: [TestTree]
tests =
[ testProperty "reverseTopologicalOrder" prop_reverseTopologicalOrder
, testProperty "executionOrder" prop_executionOrder
, testProperty "execute serial" prop_execute_serial
, testProperty "execute parallel" prop_execute_parallel
, testProperty "execute/executionOrder" prop_execute_vs_executionOrder
]
prop_reverseTopologicalOrder :: TestInstallPlan -> Bool
......@@ -35,6 +43,7 @@ prop_reverseTopologicalOrder (TestInstallPlan plan graph toVertex _) =
(map (toVertex . installedUnitId)
(InstallPlan.reverseTopologicalOrder plan))
-- | @executionOrder@ is in reverse topological order
prop_executionOrder :: TestInstallPlan -> Bool
prop_executionOrder (TestInstallPlan plan graph toVertex _) =
isReversePartialTopologicalOrder graph (map toVertex pkgids)
......@@ -42,6 +51,50 @@ prop_executionOrder (TestInstallPlan plan graph toVertex _) =
where
pkgids = map installedUnitId (InstallPlan.executionOrder plan)
-- | @execute@ is in reverse topological order
prop_execute_serial :: TestInstallPlan -> Property
prop_execute_serial tplan@(TestInstallPlan plan graph toVertex _) =
ioProperty $ do
jobCtl <- newSerialJobControl
pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ())
return $ isReversePartialTopologicalOrder graph (map toVertex pkgids)
&& allConfiguredPackages plan == Set.fromList pkgids
prop_execute_parallel :: Positive (Small Int) -> TestInstallPlan -> Property
prop_execute_parallel (Positive (Small maxJobLimit))
tplan@(TestInstallPlan plan graph toVertex _) =
ioProperty $ do
jobCtl <- newParallelJobControl maxJobLimit
pkgids <- executeTestInstallPlan jobCtl tplan $ \_ -> do
delay <- randomRIO (0,1000)
threadDelay delay
return $ isReversePartialTopologicalOrder graph (map toVertex pkgids)
&& allConfiguredPackages plan == Set.fromList pkgids
-- | return the packages that are visited by execute, in order.
executeTestInstallPlan :: JobControl IO (UnitId, Either () ())
-> TestInstallPlan
-> (TestPkg -> IO ())
-> IO [UnitId]
executeTestInstallPlan jobCtl (TestInstallPlan plan _ _ _) visit = do
resultsRef <- newIORef []
_ <- InstallPlan.execute jobCtl False (const ())
plan $ \(ReadyPackage pkg) -> do
visit pkg
atomicModifyIORef resultsRef $ \pkgs -> (installedUnitId pkg:pkgs, ())
return (Right ())
fmap reverse (readIORef resultsRef)
-- | @execute@ visits the packages in the same order as @executionOrder@
prop_execute_vs_executionOrder :: TestInstallPlan -> Property
prop_execute_vs_executionOrder tplan@(TestInstallPlan plan _ _ _) =
ioProperty $ do
jobCtl <- newSerialJobControl
pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ())
let pkgids' = map installedUnitId (InstallPlan.executionOrder plan)
return (pkgids == pkgids')
--------------------------
-- Property helper utils
--
......
Supports Markdown
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