cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# LANGUAGE TypeFamilies #-}
   3 {-# LANGUAGE NoMonoLocalBinds #-}
   4
   5 module UnitTests.Distribution.Client.InstallPlan (tests) where
   6
   7 import Distribution.Client.Compat.Prelude
   8
   9 import Distribution.Client.InstallPlan (GenericInstallPlan, IsUnit)
  10 import qualified Distribution.Client.InstallPlan as InstallPlan
  11 import Distribution.Client.JobControl
  12 import Distribution.Client.Types
  13 import Distribution.Compat.Graph (IsNode (..))
  14 import qualified Distribution.Compat.Graph as Graph
  15 import Distribution.Package
  16 import qualified Distribution.Solver.Types.ComponentDeps as CD
  17 import Distribution.Solver.Types.PackageFixedDeps
  18 import Distribution.Solver.Types.Settings
  19 import Distribution.Version
  20
  21 import Control.Concurrent (threadDelay)
  22 import Control.Monad (replicateM)
  23 import Data.Array hiding (index)
  24 import Data.Graph
  25 import Data.IORef
  26 import Data.List ()
  27 import qualified Data.Map as Map
  28 import qualified Data.Set as Set
  29 import System.Random
  30 import Test.QuickCheck
  31
  32 import Test.Tasty
  33 import Test.Tasty.QuickCheck
  34
  35 tests :: [TestTree]
  36 tests =
  37   [ testProperty "reverseTopologicalOrder" prop_reverseTopologicalOrder
  38   , testProperty "executionOrder" prop_executionOrder
  39   , testProperty "execute serial" prop_execute_serial
  40   , testProperty "execute parallel" prop_execute_parallel
  41   , testProperty "execute/executionOrder" prop_execute_vs_executionOrder
  42   ]
  43
  44 prop_reverseTopologicalOrder :: TestInstallPlan -> Bool
  45 prop_reverseTopologicalOrder (TestInstallPlan plan graph toVertex _) =
  46   isReverseTopologicalOrder
  47     graph
  48     ( map
  49         (toVertex . installedUnitId)
  50         (InstallPlan.reverseTopologicalOrder plan)
  51     )
  52
  53 -- | @executionOrder@ is in reverse topological order
  54 prop_executionOrder :: TestInstallPlan -> Bool
  55 prop_executionOrder (TestInstallPlan plan graph toVertex _) =
  56   isReversePartialTopologicalOrder graph (map toVertex pkgids)
  57     && allConfiguredPackages plan == Set.fromList pkgids
  58   where
  59     pkgids = map installedUnitId (InstallPlan.executionOrder plan)
  60
  61 -- | @execute@ is in reverse topological order
  62 prop_execute_serial :: TestInstallPlan -> Property
  63 prop_execute_serial tplan@(TestInstallPlan plan graph toVertex _) =
  64   ioProperty $ do
  65     jobCtl <- newSerialJobControl
  66     pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ())
  67     return $
  68       isReversePartialTopologicalOrder graph (map toVertex pkgids)
  69         && allConfiguredPackages plan == Set.fromList pkgids
  70
  71 prop_execute_parallel :: Positive (Small Int) -> TestInstallPlan -> Property
  72 prop_execute_parallel
  73   (Positive (Small maxJobLimit))
  74   tplan@(TestInstallPlan plan graph toVertex _) =
  75     ioProperty $ do
  76       jobCtl <- newParallelJobControl maxJobLimit
  77       pkgids <- executeTestInstallPlan jobCtl tplan $ \_ -> do
  78         delay <- randomRIO (0, 1000)
  79         threadDelay delay
  80       return $
  81         isReversePartialTopologicalOrder graph (map toVertex pkgids)
  82           && allConfiguredPackages plan == Set.fromList pkgids
  83
  84 -- | return the packages that are visited by execute, in order.
  85 executeTestInstallPlan
  86   :: JobControl IO (UnitId, Either () ())
  87   -> TestInstallPlan
  88   -> (TestPkg -> IO ())
  89   -> IO [UnitId]
  90 executeTestInstallPlan jobCtl (TestInstallPlan plan _ _ _) visit = do
  91   resultsRef <- newIORef []
  92   _ <- InstallPlan.execute
  93     jobCtl
  94     False
  95     (const ())
  96     plan
  97     $ \(ReadyPackage pkg) -> do
  98       visit pkg
  99       atomicModifyIORef resultsRef $ \pkgs -> (installedUnitId pkg : pkgs, ())
 100       return (Right ())
 101   fmap reverse (readIORef resultsRef)
 102
 103 -- | @execute@ visits the packages in the same order as @executionOrder@
 104 prop_execute_vs_executionOrder :: TestInstallPlan -> Property
 105 prop_execute_vs_executionOrder tplan@(TestInstallPlan plan _ _ _) =
 106   ioProperty $ do
 107     jobCtl <- newSerialJobControl
 108     pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ())
 109     let pkgids' = map installedUnitId (InstallPlan.executionOrder plan)
 110     return (pkgids == pkgids')
 111
 112 --------------------------
 113 -- Property helper utils
 114 --
 115
 116 -- | A graph topological ordering is a linear ordering of its vertices such
 117 -- that for every directed edge uv from vertex u to vertex v, u comes before v
 118 -- in the ordering.
 119 --
 120 -- A reverse topological ordering is the swapped: for every directed edge uv
 121 -- from vertex u to vertex v, v comes before u in the ordering.
 122 isReverseTopologicalOrder :: Graph -> [Vertex] -> Bool
 123 isReverseTopologicalOrder g vs =
 124   and
 125     [ ixs ! u > ixs ! v
 126     | let ixs = array (bounds g) (zip vs [0 :: Int ..])
 127     , (u, v) <- edges g
 128     ]
 129
 130 isReversePartialTopologicalOrder :: Graph -> [Vertex] -> Bool
 131 isReversePartialTopologicalOrder g vs =
 132   and
 133     [ case (ixs ! u, ixs ! v) of
 134       (Just ixu, Just ixv) -> ixu > ixv
 135       _ -> True
 136     | let ixs =
 137             array
 138               (bounds g)
 139               ( zip (range (bounds g)) (repeat Nothing)
 140                   ++ zip vs (map Just [0 :: Int ..])
 141               )
 142     , (u, v) <- edges g
 143     ]
 144
 145 allConfiguredPackages
 146   :: HasUnitId srcpkg
 147   => GenericInstallPlan ipkg srcpkg
 148   -> Set UnitId
 149 allConfiguredPackages plan =
 150   Set.fromList
 151     [ installedUnitId pkg
 152     | InstallPlan.Configured pkg <- InstallPlan.toList plan
 153     ]
 154
 155 --------------------
 156 -- Test generators
 157 --
 158
 159 data TestInstallPlan
 160   = TestInstallPlan
 161       (GenericInstallPlan TestPkg TestPkg)
 162       Graph
 163       (UnitId -> Vertex)
 164       (Vertex -> UnitId)
 165
 166 instance Show TestInstallPlan where
 167   show (TestInstallPlan plan _ _ _) = InstallPlan.showInstallPlan plan
 168
 169 data TestPkg = TestPkg PackageId UnitId [UnitId]
 170   deriving (Eq, Show)
 171
 172 instance IsNode TestPkg where
 173   type Key TestPkg = UnitId
 174   nodeKey (TestPkg _ ipkgid _) = ipkgid
 175   nodeNeighbors (TestPkg _ _ deps) = deps
 176
 177 instance Package TestPkg where
 178   packageId (TestPkg pkgid _ _) = pkgid
 179
 180 instance HasUnitId TestPkg where
 181   installedUnitId (TestPkg _ ipkgid _) = ipkgid
 182
 183 instance PackageFixedDeps TestPkg where
 184   depends (TestPkg _ _ deps) = CD.singleton CD.ComponentLib deps
 185
 186 instance PackageInstalled TestPkg where
 187   installedDepends (TestPkg _ _ deps) = deps
 188
 189 instance Arbitrary TestInstallPlan where
 190   arbitrary = arbitraryTestInstallPlan
 191
 192 arbitraryTestInstallPlan :: Gen TestInstallPlan
 193 arbitraryTestInstallPlan = do
 194   graph <-
 195     arbitraryAcyclicGraph
 196       (choose (2, 5))
 197       (choose (1, 5))
 198       0.3
 199
 200   plan <- arbitraryInstallPlan mkTestPkg mkTestPkg 0.5 graph
 201
 202   let toVertexMap = Map.fromList [(mkUnitIdV v, v) | v <- vertices graph]
 203       fromVertexMap = Map.fromList [(v, mkUnitIdV v) | v <- vertices graph]
 204       toVertex = (toVertexMap Map.!)
 205       fromVertex = (fromVertexMap Map.!)
 206
 207   return (TestInstallPlan plan graph toVertex fromVertex)
 208   where
 209     mkTestPkg pkgv depvs =
 210       return (TestPkg pkgid ipkgid deps)
 211       where
 212         pkgid = mkPkgId pkgv
 213         ipkgid = mkUnitIdV pkgv
 214         deps = map mkUnitIdV depvs
 215     mkUnitIdV = mkUnitId . show
 216     mkPkgId v =
 217       PackageIdentifier
 218         (mkPackageName ("pkg" ++ show v))
 219         (mkVersion [1])
 220
 221 -- | Generate a random 'InstallPlan' following the structure of an existing
 222 -- 'Graph'.
 223 --
 224 -- It takes generators for installed and source packages and the chance that
 225 -- each package is installed (for those packages with no prerequisites).
 226 arbitraryInstallPlan
 227   :: ( IsUnit ipkg
 228      , IsUnit srcpkg
 229      )
 230   => (Vertex -> [Vertex] -> Gen ipkg)
 231   -> (Vertex -> [Vertex] -> Gen srcpkg)
 232   -> Float
 233   -> Graph
 234   -> Gen (InstallPlan.GenericInstallPlan ipkg srcpkg)
 235 arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do
 236   (ipkgvs, srcpkgvs) <-
 237     fmap
 238       ( (\(ipkgs, srcpkgs) -> (map fst ipkgs, map fst srcpkgs))
 239           . partition snd
 240       )
 241       $ sequenceA
 242         [ do
 243           isipkg <-
 244             if isRoot
 245               then pick ipkgProportion
 246               else return False
 247           return (v, isipkg)
 248         | (v, n) <- assocs (outdegree graph)
 249         , let isRoot = n == 0
 250         ]
 251
 252   ipkgs <-
 253     sequenceA
 254       [ mkIPkg pkgv depvs
 255       | pkgv <- ipkgvs
 256       , let depvs = graph ! pkgv
 257       ]
 258   srcpkgs <-
 259     sequenceA
 260       [ mkSrcPkg pkgv depvs
 261       | pkgv <- srcpkgvs
 262       , let depvs = graph ! pkgv
 263       ]
 264   let index =
 265         Graph.fromDistinctList
 266           ( map InstallPlan.PreExisting ipkgs
 267               ++ map InstallPlan.Configured srcpkgs
 268           )
 269   return $ InstallPlan.new (IndependentGoals False) index
 270
 271 -- | Generate a random directed acyclic graph, based on the algorithm presented
 272 -- here <http://stackoverflow.com/questions/12790337/generating-a-random-dag>
 273 --
 274 -- It generates a DAG based on ranks of nodes. Nodes in each rank can only
 275 -- have edges to nodes in subsequent ranks.
 276 --
 277 -- The generator is parametrised by a generator for the number of ranks and
 278 -- the number of nodes within each rank. It is also parametrised by the
 279 -- chance that each node in each rank will have an edge from each node in
 280 -- each previous rank. Thus a higher chance will produce a more densely
 281 -- connected graph.
 282 arbitraryAcyclicGraph :: Gen Int -> Gen Int -> Float -> Gen Graph
 283 arbitraryAcyclicGraph genNRanks genNPerRank edgeChance = do
 284   nranks <- genNRanks
 285   rankSizes <- replicateM nranks genNPerRank
 286   let rankStarts = scanl (+) 0 rankSizes
 287       rankRanges = drop 1 (zip rankStarts (drop 1 rankStarts))
 288       totalRange = sum rankSizes
 289   rankEdges <- traverse (uncurry genRank) rankRanges
 290   return $ buildG (0, totalRange - 1) (concat rankEdges)
 291   where
 292     genRank :: Vertex -> Vertex -> Gen [Edge]
 293     genRank rankStart rankEnd =
 294       filterM
 295         (const (pick edgeChance))
 296         [ (i, j)
 297         | i <- [0 .. rankStart - 1]
 298         , j <- [rankStart .. rankEnd - 1]
 299         ]
 300
 301 pick :: Float -> Gen Bool
 302 pick chance = do
 303   p <- choose (0, 1)
 304   return (p < chance)
 305
 306 --------------------------------
 307 -- Inspecting generated graphs
 308 --
 309
 310 {-
 311 -- Handy util for checking the generated graphs look sensible
 312 writeDotFile :: FilePath -> Graph -> IO ()
 313 writeDotFile file = writeFile file . renderDotGraph
 314
 315 renderDotGraph :: Graph -> String
 316 renderDotGraph graph =
 317   unlines (
 318       [header
 319       ,graphDefaultAtribs
 320       ,nodeDefaultAtribs
 321       ,edgeDefaultAtribs]
 322     ++ map renderNode (vertices graph)
 323     ++ map renderEdge (edges graph)
 324     ++ [footer]
 325   )
 326   where
 327     renderNode n = "\t" ++ show n ++ " [label=\"" ++ show n ++  "\"];"
 328
 329     renderEdge (n, n') = "\t" ++ show n ++ " -> " ++ show n' ++ "[];"
 330
 331 header, footer, graphDefaultAtribs, nodeDefaultAtribs, edgeDefaultAtribs :: String
 332
 333 header = "digraph packages {"
 334 footer = "}"
 335
 336 graphDefaultAtribs = "\tgraph [fontsize=14, fontcolor=black, color=black];"
 337 nodeDefaultAtribs  = "\tnode [label=\"\\N\", width=\"0.75\", shape=ellipse];"
 338 edgeDefaultAtribs  = "\tedge [fontsize=10];"
 339 -}