git.iko.soy/stackage
on master help sign in
Check for cycles when checking a build plan #375
d08d1b6Chris Done
Stackage/CheckBuildPlan.hs+54−9
compare with master
unifiedsplit
@@ -1,3 +1,4 @@
1+{-# LANGUAGE TupleSections #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE NoImplicitPrelude #-}
4{-# LANGUAGE NoImplicitPrelude #-}
@@ -11,30 +12,34 @@ module Stackage.CheckBuildPlan
11 ) where
12 ) where
12
13
13import Control.Monad.Writer.Strict (Writer, execWriter, tell)
14import Control.Monad.Writer.Strict (Writer, execWriter, tell)
14−import qualified Data.Text as T
15+import qualified Data.Map.Strict as M
16+import qualified Data.Text as T
15import Stackage.BuildConstraints
17import Stackage.BuildConstraints
16import Stackage.BuildPlan
18import Stackage.BuildPlan
17import Stackage.PackageDescription
19import Stackage.PackageDescription
18import Stackage.Prelude
20import Stackage.Prelude
19
21
20−-- FIXME check cycles in dependencies, only looking at libraries and
21−-- executables
22−
23-- | Check the build plan for missing deps, wrong versions, etc.
22-- | Check the build plan for missing deps, wrong versions, etc.
24−checkBuildPlan :: MonadThrow m => BuildPlan -> m ()
23+checkBuildPlan :: (MonadThrow m) => BuildPlan -> m ()
25checkBuildPlan BuildPlan {..}
24checkBuildPlan BuildPlan {..}
26 | null errs' = return ()
25 | null errs' = return ()
27 | otherwise = throwM errs
26 | otherwise = throwM errs
28 where
27 where
29− allPackages = siCorePackages bpSystemInfo ++ map ppVersion bpPackages
28+ allPackages = map (,mempty) (siCorePackages bpSystemInfo) ++
29+ map (ppVersion &&& M.keys . M.filter libAndExe . sdPackages . ppDesc) bpPackages
30 errs@(BadBuildPlan errs') =
30 errs@(BadBuildPlan errs') =
31 execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages
31 execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages
32+ -- Only looking at libraries and executables, benchmarks and tests
33+ -- are allowed to create cycles (e.g. test-framework depends on
34+ -- text, which uses test-framework in its test-suite).
35+ libAndExe (DepInfo cs _) = any (flip elem [CompLibrary,CompExecutable]) cs
32
36
33-- | For a given package name and plan, check that its dependencies are:
37-- | For a given package name and plan, check that its dependencies are:
34--
38--
35-- 1. Existent (existing in the provided package map)
39-- 1. Existent (existing in the provided package map)
36-- 2. Within version range
40-- 2. Within version range
41+-- 3. Check for dependency cycles.
37−checkDeps :: Map PackageName Version
42+checkDeps :: Map PackageName (Version,[PackageName])
38 -> (PackageName, PackagePlan)
43 -> (PackageName, PackagePlan)
39 -> Writer BadBuildPlan ()
44 -> Writer BadBuildPlan ()
40checkDeps allPackages (user, pb) =
45checkDeps allPackages (user, pb) =
@@ -43,8 +48,16 @@ checkDeps allPackages (user, pb) =
43 go (dep, diRange -> range) =
48 go (dep, diRange -> range) =
44 case lookup dep allPackages of
49 case lookup dep allPackages of
45 Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap
50 Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap
46− Just version
51+ Just (version,deps)
47− | version `withinRange` range -> return ()
52+ | version `withinRange` range ->
53+ occursCheck allPackages
54+ (\d v ->
55+ tell $ BadBuildPlan $ singletonMap
56+ (d,v)
57+ errMap)
58+ dep
59+ deps
60+ []
48 | otherwise -> tell $ BadBuildPlan $ singletonMap
61 | otherwise -> tell $ BadBuildPlan $ singletonMap
49 (dep, Just version)
62 (dep, Just version)
50 errMap
63 errMap
@@ -57,6 +70,38 @@ checkDeps allPackages (user, pb) =
57 , puGithubPings = ppGithubPings pb
70 , puGithubPings = ppGithubPings pb
58 }
71 }
59
72
73+-- | Check whether the package(s) occurs within its own dependency
74+-- tree.
75+occursCheck
76+ :: Monad m
77+ => Map PackageName (Version,[PackageName])
78+ -- ^ All packages.
79+ -> (PackageName -> Maybe Version -> m ())
80+ -- ^ Report an erroneous package.
81+ -> PackageName
82+ -- ^ Starting package to check for cycles in.
83+ -> [PackageName]
84+ -- ^ Dependencies of the package.
85+ -> [PackageName]
86+ -- ^ Previously seen packages up the dependency tree.
87+ -> m ()
88+occursCheck allPackages reportError =
89+ go
90+ where
91+ go pkg deps seen =
92+ case find (flip elem seen) deps of
93+ Just cyclic ->
94+ reportError cyclic $
95+ fmap fst (lookup cyclic allPackages)
96+ Nothing ->
97+ forM_ deps $
98+ \pkg' ->
99+ case lookup pkg' allPackages of
100+ Just (_v,deps')
101+ | pkg' /= pkg -> go pkg' deps' seen'
102+ _ -> return ()
103+ where seen' = pkg : seen
104+
60data PkgUser = PkgUser
105data PkgUser = PkgUser
61 { puName :: PackageName
106 { puName :: PackageName
62 , puVersion :: Version
107 , puVersion :: Version
test/Stackage/BuildPlanSpec.hs+9−1
@@ -29,7 +29,15 @@ spec = do
29 it "nonexistent package fails to check" $ badBuildPlan $ makePackageSet
29 it "nonexistent package fails to check" $ badBuildPlan $ makePackageSet
30 [("foo", [0, 0, 0], [("nonexistent", thisV [0, 0, 0])])
30 [("foo", [0, 0, 0], [("nonexistent", thisV [0, 0, 0])])
31 ,("bar", [0, 0, 0], [])]
31 ,("bar", [0, 0, 0], [])]
32+ it "mutual cycles fail to check" $ badBuildPlan $ makePackageSet
33+ [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])])
34+ ,("bar", [0, 0, 0], [("foo", thisV [0, 0, 0])])]
35+ it "nested cycles fail to check" $ badBuildPlan $ makePackageSet
36+ [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])])
37+ ,("bar", [0, 0, 0], [("mu", thisV [0, 0, 0])])
38+ ,("mu", [0, 0, 0], [("foo", thisV [0, 0, 0])])]
39+ it "default package set checks ok" $
32− it "default package set checks ok" $ check defaultBuildConstraints getLatestAllowedPlans
40+ check defaultBuildConstraints getLatestAllowedPlans
33
41
34-- | Checking should be considered a bad build plan.
42-- | Checking should be considered a bad build plan.
35badBuildPlan :: (BuildConstraints -> IO (Map PackageName PackagePlan))
43badBuildPlan :: (BuildConstraints -> IO (Map PackageName PackagePlan))