Check for cycles when checking a build plan #375

Stackage/CheckBuildPlan.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NoImplicitPrelude          #-}
@@ -11,30 +12,34 @@ module Stackage.CheckBuildPlan
     ) where
 
 import           Control.Monad.Writer.Strict (Writer, execWriter, tell)
-import qualified Data.Text                   as T
+import qualified Data.Map.Strict as M
+import qualified Data.Text as T
 import           Stackage.BuildConstraints
 import           Stackage.BuildPlan
 import           Stackage.PackageDescription
 import           Stackage.Prelude
 
--- FIXME check cycles in dependencies, only looking at libraries and
--- executables
-
 -- | Check the build plan for missing deps, wrong versions, etc.
-checkBuildPlan :: MonadThrow m => BuildPlan -> m ()
+checkBuildPlan :: (MonadThrow m) => BuildPlan -> m ()
 checkBuildPlan BuildPlan {..}
     | null errs' = return ()
     | otherwise = throwM errs
   where
-    allPackages = siCorePackages bpSystemInfo ++ map ppVersion bpPackages
+    allPackages = map (,mempty) (siCorePackages bpSystemInfo) ++
+                  map (ppVersion &&& M.keys . M.filter libAndExe . sdPackages . ppDesc) bpPackages
     errs@(BadBuildPlan errs') =
         execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages
+    -- Only looking at libraries and executables, benchmarks and tests
+    -- are allowed to create cycles (e.g. test-framework depends on
+    -- text, which uses test-framework in its test-suite).
+    libAndExe (DepInfo cs _) = any (flip elem [CompLibrary,CompExecutable]) cs
 
 -- | For a given package name and plan, check that its dependencies are:
 --
 -- 1. Existent (existing in the provided package map)
 -- 2. Within version range
-checkDeps :: Map PackageName Version
+-- 3. Check for dependency cycles.
+checkDeps :: Map PackageName (Version,[PackageName])
           -> (PackageName, PackagePlan)
           -> Writer BadBuildPlan ()
 checkDeps allPackages (user, pb) =
@@ -43,8 +48,16 @@ checkDeps allPackages (user, pb) =
     go (dep, diRange -> range) =
         case lookup dep allPackages of
             Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap
-            Just version
+            Just (version,deps)
-                | version `withinRange` range -> return ()
+                | version `withinRange` range ->
+                    occursCheck allPackages
+                                (\d v ->
+                                     tell $ BadBuildPlan $ singletonMap
+                                     (d,v)
+                                     errMap)
+                                dep
+                                deps
+                                []
                 | otherwise -> tell $ BadBuildPlan $ singletonMap
                     (dep, Just version)
                     errMap
@@ -57,6 +70,38 @@ checkDeps allPackages (user, pb) =
             , puGithubPings = ppGithubPings pb
             }
 
+-- | Check whether the package(s) occurs within its own dependency
+-- tree.
+occursCheck
+    :: Monad m
+    => Map PackageName (Version,[PackageName])
+    -- ^ All packages.
+    -> (PackageName -> Maybe Version -> m ())
+    -- ^ Report an erroneous package.
+    -> PackageName
+    -- ^ Starting package to check for cycles in.
+    -> [PackageName]
+    -- ^ Dependencies of the package.
+    -> [PackageName]
+    -- ^ Previously seen packages up the dependency tree.
+    -> m ()
+occursCheck allPackages reportError =
+    go
+    where
+        go pkg deps seen =
+            case find (flip elem seen) deps of
+                Just cyclic ->
+                    reportError cyclic $
+                    fmap fst (lookup cyclic allPackages)
+                Nothing ->
+                    forM_ deps $
+                    \pkg' ->
+                         case lookup pkg' allPackages of
+                             Just (_v,deps')
+                                 | pkg' /= pkg -> go pkg' deps' seen'
+                             _ -> return ()
+            where seen' = pkg : seen
+
 data PkgUser = PkgUser
     { puName        :: PackageName
     , puVersion     :: Version

test/Stackage/BuildPlanSpec.hs

@@ -29,7 +29,15 @@ spec = do
     it "nonexistent package fails to check" $ badBuildPlan $ makePackageSet
         [("foo", [0, 0, 0], [("nonexistent", thisV [0, 0, 0])])
         ,("bar", [0, 0, 0], [])]
-    it "default package set checks ok" $ check defaultBuildConstraints getLatestAllowedPlans
+    it "mutual cycles fail to check" $ badBuildPlan $ makePackageSet
+        [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])])
+        ,("bar", [0, 0, 0], [("foo", thisV [0, 0, 0])])]
+    it "nested cycles fail to check" $ badBuildPlan $ makePackageSet
+        [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])])
+        ,("bar", [0, 0, 0], [("mu", thisV [0, 0, 0])])
+        ,("mu", [0, 0, 0], [("foo", thisV [0, 0, 0])])]
+    it "default package set checks ok" $
+      check defaultBuildConstraints getLatestAllowedPlans
 
 -- | Checking should be considered a bad build plan.
 badBuildPlan :: (BuildConstraints -> IO (Map PackageName PackagePlan))