git.iko.soy/stackage
on 87668d2 help sign in
stackage/Stackage/CheckBuildPlan.hs
162 lines 5.8 kB history raw
1{-# LANGUAGE TupleSections #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE NoImplicitPrelude #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE RecordWildCards #-}
7{-# LANGUAGE ViewPatterns #-}
8-- | Confirm that a build plan has a consistent set of dependencies.
9module Stackage.CheckBuildPlan
10 ( checkBuildPlan
11 , BadBuildPlan
12 ) where
14import Control.Monad.Writer.Strict (Writer, execWriter, tell)
15import qualified Data.Map.Strict as M
16import qualified Data.Text as T
17import Stackage.BuildConstraints
18import Stackage.BuildPlan
19import Stackage.PackageDescription
20import Stackage.Prelude
22-- | Check the build plan for missing deps, wrong versions, etc.
23checkBuildPlan :: (MonadThrow m) => BuildPlan -> m ()
24checkBuildPlan BuildPlan {..}
25 | null errs' = return ()
26 | otherwise = throwM errs
27 where
28 allPackages = map (,mempty) (siCorePackages bpSystemInfo) ++
29 map (ppVersion &&& M.keys . M.filter libAndExe . sdPackages . ppDesc) bpPackages
30 errs@(BadBuildPlan errs') =
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
37-- | For a given package name and plan, check that its dependencies are:
38--
39-- 1. Existent (existing in the provided package map)
40-- 2. Within version range
41-- 3. Check for dependency cycles.
42checkDeps :: Map PackageName (Version,[PackageName])
43 -> (PackageName, PackagePlan)
44 -> Writer BadBuildPlan ()
45checkDeps allPackages (user, pb) =
46 mapM_ go $ mapToList $ sdPackages $ ppDesc pb
47 where
48 go (dep, diRange -> range) =
49 case lookup dep allPackages of
50 Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap
51 Just (version,deps)
52 | version `withinRange` range ->
53 occursCheck allPackages
54 (\d v ->
55 tell $ BadBuildPlan $ singletonMap
56 (d,v)
57 errMap)
58 dep
59 deps
60 []
61 | otherwise -> tell $ BadBuildPlan $ singletonMap
62 (dep, Just version)
63 errMap
64 where
65 errMap = singletonMap pu range
66 pu = PkgUser
67 { puName = user
68 , puVersion = ppVersion pb
69 , puMaintainer = pcMaintainer $ ppConstraints pb
70 , puGithubPings = ppGithubPings pb
71 }
73-- | Check whether the package(s) occurs within its own dependency
74-- tree.
75occursCheck
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 ()
88occursCheck 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
105data PkgUser = PkgUser
106 { puName :: PackageName
107 , puVersion :: Version
108 , puMaintainer :: Maybe Maintainer
109 , puGithubPings :: Set Text
110 }
111 deriving (Eq, Ord)
113pkgUserShow1 :: PkgUser -> Text
114pkgUserShow1 PkgUser {..} = concat
115 [ display puName
116 , "-"
117 , display puVersion
118 ]
120pkgUserShow2 :: PkgUser -> Text
121pkgUserShow2 PkgUser {..} = unwords
122 $ (maybe "No maintainer" unMaintainer puMaintainer ++ ".")
123 : map (cons '@') (setToList puGithubPings)
125newtype BadBuildPlan =
126 BadBuildPlan (Map (PackageName, Maybe Version) (Map PkgUser VersionRange))
127 deriving Typeable
128instance Exception BadBuildPlan
129instance Show BadBuildPlan where
130 show (BadBuildPlan errs) =
131 unpack $ concatMap go $ mapToList errs
132 where
133 go ((dep, mdepVer), users) = unlines
134 $ ""
135 : showDepVer dep mdepVer
136 : map showUser (mapToList users)
138 showDepVer :: PackageName -> Maybe Version -> Text
139 showDepVer dep Nothing = display dep ++ " (not present) depended on by:"
140 showDepVer dep (Just version) = concat
141 [ display dep
142 , "-"
143 , display version
144 , " depended on by:"
145 ]
147 showUser :: (PkgUser, VersionRange) -> Text
148 showUser (pu, range) = concat
149 [ "- "
150 , pkgUserShow1 pu
151 , " ("
152 -- add a space after < to avoid confusing Markdown processors (like
153 -- Github's issue tracker)
154 , T.replace "<" "< " $ display range
155 , "). "
156 , pkgUserShow2 pu
157 ]
159instance Monoid BadBuildPlan where
160 mempty = BadBuildPlan mempty
161 mappend (BadBuildPlan x) (BadBuildPlan y) =
162 BadBuildPlan $ unionWith (unionWith intersectVersionRanges) x y