{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonoLocalBinds #-} {-# LANGUAGE ConstraintKinds #-} module UnitTests.Distribution.Client.InstallPlan (tests) where import Distribution.Package import Distribution.Version import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (GenericInstallPlan, IsUnit) import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph (IsNode(..)) import Distribution.Solver.Types.Settings import Distribution.Solver.Types.PackageFixedDeps import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Client.Types import Distribution.Client.JobControl import Data.Graph import Data.Array hiding (index) 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 import Test.Tasty.QuickCheck 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 prop_reverseTopologicalOrder (TestInstallPlan plan graph toVertex _) = isReverseTopologicalOrder graph (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) && allConfiguredPackages plan == Set.fromList pkgids 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 -- -- | A graph topological ordering is a linear ordering of its vertices such -- that for every directed edge uv from vertex u to vertex v, u comes before v -- in the ordering. -- -- A reverse topological ordering is the swapped: for every directed edge uv -- from vertex u to vertex v, v comes before u in the ordering. -- isReverseTopologicalOrder :: Graph -> [Vertex] -> Bool isReverseTopologicalOrder g vs = and [ ixs ! u > ixs ! v | let ixs = array (bounds g) (zip vs [0::Int ..]) , (u,v) <- edges g ] isReversePartialTopologicalOrder :: Graph -> [Vertex] -> Bool isReversePartialTopologicalOrder g vs = and [ case (ixs ! u, ixs ! v) of (Just ixu, Just ixv) -> ixu > ixv _ -> True | let ixs = array (bounds g) (zip (range (bounds g)) (repeat Nothing) ++ zip vs (map Just [0::Int ..])) , (u,v) <- edges g ] allConfiguredPackages :: HasUnitId srcpkg => GenericInstallPlan ipkg srcpkg -> Set UnitId allConfiguredPackages plan = Set.fromList [ installedUnitId pkg | InstallPlan.Configured pkg <- InstallPlan.toList plan ] -------------------- -- Test generators -- data TestInstallPlan = TestInstallPlan (GenericInstallPlan TestPkg TestPkg) Graph (UnitId -> Vertex) (Vertex -> UnitId) instance Show TestInstallPlan where show (TestInstallPlan plan _ _ _) = InstallPlan.showInstallPlan plan data TestPkg = TestPkg PackageId UnitId [UnitId] deriving (Eq, Show) instance IsNode TestPkg where type Key TestPkg = UnitId nodeKey (TestPkg _ ipkgid _) = ipkgid nodeNeighbors (TestPkg _ _ deps) = deps instance Package TestPkg where packageId (TestPkg pkgid _ _) = pkgid instance HasUnitId TestPkg where installedUnitId (TestPkg _ ipkgid _) = ipkgid instance PackageFixedDeps TestPkg where depends (TestPkg _ _ deps) = CD.singleton CD.ComponentLib deps instance PackageInstalled TestPkg where installedDepends (TestPkg _ _ deps) = deps instance Arbitrary TestInstallPlan where arbitrary = arbitraryTestInstallPlan arbitraryTestInstallPlan :: Gen TestInstallPlan arbitraryTestInstallPlan = do graph <- arbitraryAcyclicGraph (choose (2,5)) (choose (1,5)) 0.3 plan <- arbitraryInstallPlan mkTestPkg mkTestPkg 0.5 graph let toVertexMap = Map.fromList [ (mkUnitIdV v, v) | v <- vertices graph ] fromVertexMap = Map.fromList [ (v, mkUnitIdV v) | v <- vertices graph ] toVertex = (toVertexMap Map.!) fromVertex = (fromVertexMap Map.!) return (TestInstallPlan plan graph toVertex fromVertex) where mkTestPkg pkgv depvs = return (TestPkg pkgid ipkgid deps) where pkgid = mkPkgId pkgv ipkgid = mkUnitIdV pkgv deps = map mkUnitIdV depvs mkUnitIdV = mkUnitId . show mkPkgId v = PackageIdentifier (mkPackageName ("pkg" ++ show v)) (mkVersion [1]) -- | Generate a random 'InstallPlan' following the structure of an existing -- 'Graph'. -- -- It takes generators for installed and source packages and the chance that -- each package is installed (for those packages with no prerequisites). -- arbitraryInstallPlan :: (IsUnit ipkg, IsUnit srcpkg) => (Vertex -> [Vertex] -> Gen ipkg) -> (Vertex -> [Vertex] -> Gen srcpkg) -> Float -> Graph -> Gen (InstallPlan.GenericInstallPlan ipkg srcpkg) arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do (ipkgvs, srcpkgvs) <- fmap ((\(ipkgs, srcpkgs) -> (map fst ipkgs, map fst srcpkgs)) . partition snd) $ sequence [ do isipkg <- if isRoot then pick ipkgProportion else return False return (v, isipkg) | (v,n) <- assocs (outdegree graph) , let isRoot = n == 0 ] ipkgs <- sequence [ mkIPkg pkgv depvs | pkgv <- ipkgvs , let depvs = graph ! pkgv ] srcpkgs <- sequence [ mkSrcPkg pkgv depvs | pkgv <- srcpkgvs , let depvs = graph ! pkgv ] let index = Graph.fromDistinctList (map InstallPlan.PreExisting ipkgs ++ map InstallPlan.Configured srcpkgs) return $ InstallPlan.new (IndependentGoals False) index -- | Generate a random directed acyclic graph, based on the algorithm presented -- here -- -- It generates a DAG based on ranks of nodes. Nodes in each rank can only -- have edges to nodes in subsequent ranks. -- -- The generator is paramterised by a generator for the number of ranks and -- the number of nodes within each rank. It is also paramterised by the -- chance that each node in each rank will have an edge from each node in -- each previous rank. Thus a higher chance will produce a more densely -- connected graph. -- arbitraryAcyclicGraph :: Gen Int -> Gen Int -> Float -> Gen Graph arbitraryAcyclicGraph genNRanks genNPerRank edgeChance = do nranks <- genNRanks rankSizes <- replicateM nranks genNPerRank let rankStarts = scanl (+) 0 rankSizes rankRanges = drop 1 (zip rankStarts (tail rankStarts)) totalRange = sum rankSizes rankEdges <- mapM (uncurry genRank) rankRanges return $ buildG (0, totalRange-1) (concat rankEdges) where genRank :: Vertex -> Vertex -> Gen [Edge] genRank rankStart rankEnd = filterM (const (pick edgeChance)) [ (i,j) | i <- [0..rankStart-1] , j <- [rankStart..rankEnd-1] ] pick :: Float -> Gen Bool pick chance = do p <- choose (0,1) return (p < chance) -------------------------------- -- Inspecting generated graphs -- {- -- Handy util for checking the generated graphs look sensible writeDotFile :: FilePath -> Graph -> IO () writeDotFile file = writeFile file . renderDotGraph renderDotGraph :: Graph -> String renderDotGraph graph = unlines ( [header ,graphDefaultAtribs ,nodeDefaultAtribs ,edgeDefaultAtribs] ++ map renderNode (vertices graph) ++ map renderEdge (edges graph) ++ [footer] ) where renderNode n = "\t" ++ show n ++ " [label=\"" ++ show n ++ "\"];" renderEdge (n, n') = "\t" ++ show n ++ " -> " ++ show n' ++ "[];" header, footer, graphDefaultAtribs, nodeDefaultAtribs, edgeDefaultAtribs :: String header = "digraph packages {" footer = "}" graphDefaultAtribs = "\tgraph [fontsize=14, fontcolor=black, color=black];" nodeDefaultAtribs = "\tnode [label=\"\\N\", width=\"0.75\", shape=ellipse];" edgeDefaultAtribs = "\tedge [fontsize=10];" -}