git.iko.soy/stackage
on master help sign in
Flexible tests for checkBuildPlan (#375)
45b33acChris Done
Stackage/BuildConstraints.hs+1
compare with master
unifiedsplit
@@ -10,6 +10,7 @@ module Stackage.BuildConstraints
10 , SystemInfo (..)
10 , SystemInfo (..)
11 , getSystemInfo
11 , getSystemInfo
12 , defaultBuildConstraints
12 , defaultBuildConstraints
13+ , toBC
13 ) where
14 ) where
14
15
15import Control.Monad.Writer.Strict (execWriter, tell)
16import Control.Monad.Writer.Strict (execWriter, tell)
Stackage/CheckBuildPlan.hs+1
@@ -7,6 +7,7 @@
7-- | Confirm that a build plan has a consistent set of dependencies.
7-- | Confirm that a build plan has a consistent set of dependencies.
8module Stackage.CheckBuildPlan
8module Stackage.CheckBuildPlan
9 ( checkBuildPlan
9 ( checkBuildPlan
10+ , BadBuildPlan
10 ) where
11 ) where
11
12
12import Control.Monad.Writer.Strict (Writer, execWriter, tell)
13import Control.Monad.Writer.Strict (Writer, execWriter, tell)
test/Stackage/BuildPlanSpec.hs+109−15
@@ -1,22 +1,56 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
1{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}
2{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}
2module Stackage.BuildPlanSpec (spec) where
3module Stackage.BuildPlanSpec (spec) where
3
4
4−import Stackage.BuildPlan
5−import Stackage.Prelude
6−import Stackage.BuildConstraints
7−import Stackage.UpdateBuildPlan
8−import Test.Hspec
9−import qualified Data.Yaml as Y
10−import Distribution.Version (anyVersion)
11import qualified Data.Map as Map
5import qualified Data.Map as Map
6+import qualified Data.Map.Strict as M
7+import qualified Data.Set as S
8+import Data.Yaml
9+import qualified Data.Yaml as Y
10+import Distribution.Version
12−import Network.HTTP.Client (withManager)
11+import Network.HTTP.Client
13−import Network.HTTP.Client.TLS (tlsManagerSettings)
12+import Network.HTTP.Client.TLS (tlsManagerSettings)
13+import Stackage.BuildConstraints
14+import Stackage.BuildPlan
15+import Stackage.CheckBuildPlan
16+import Stackage.PackageDescription
17+import Stackage.Prelude
18+import Stackage.UpdateBuildPlan
19+import Test.Hspec
14
20
15spec :: Spec
21spec :: Spec
22+spec = do
23+ it "simple package set" $ check testBuildConstraints $ makePackageSet
24+ [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])])
25+ ,("bar", [0, 0, 0], [])]
26+ it "bad version range on depdendency fails" $ badBuildPlan $ makePackageSet
27+ [("foo", [0, 0, 0], [("bar", thisV [1, 1, 0])])
28+ ,("bar", [0, 0, 0], [])]
29+ it "nonexistent package fails to check" $ badBuildPlan $ makePackageSet
30+ [("foo", [0, 0, 0], [("nonexistent", thisV [0, 0, 0])])
31+ ,("bar", [0, 0, 0], [])]
32+ it "default package set checks ok" $ check defaultBuildConstraints getLatestAllowedPlans
33+
34+-- | Checking should be considered a bad build plan.
35+badBuildPlan :: (BuildConstraints -> IO (Map PackageName PackagePlan))
36+ -> void
37+ -> IO ()
38+badBuildPlan m _ = do
39+ mu <- try (check testBuildConstraints m)
40+ case mu of
41+ Left (_ :: BadBuildPlan) ->
42+ return ()
43+ Right () ->
44+ error "Expected bad build plan."
45+
46+-- | Check build plan with the given package set getter.
47+check :: (Manager -> IO BuildConstraints)
48+ -> (BuildConstraints -> IO (Map PackageName PackagePlan))
49+ -> IO ()
16−spec = it "works" $ withManager tlsManagerSettings $ \man -> do
50+check readPlanFile getPlans = withManager tlsManagerSettings $ \man -> do
17− bc <- defaultBuildConstraints man
51+ bc <- readPlanFile man
18− pkgs <- getLatestAllowedPlans bc
52+ plans <- getPlans bc
19− bp <- newBuildPlan pkgs bc
53+ bp <- newBuildPlan plans bc
20 let bs = Y.encode bp
54 let bs = Y.encode bp
21 ebp' = Y.decodeEither bs
55 ebp' = Y.decodeEither bs
22
56
@@ -26,14 +60,74 @@ spec = it "works" $ withManager tlsManagerSettings $ \man -> do
26 forM_ allPackages $ \name ->
60 forM_ allPackages $ \name ->
27 (name, lookup name (bpPackages bp')) `shouldBe`
61 (name, lookup name (bpPackages bp')) `shouldBe`
28 (name, lookup name (bpPackages bp))
62 (name, lookup name (bpPackages bp))
29−
30 bpGithubUsers bp' `shouldBe` bpGithubUsers bp
63 bpGithubUsers bp' `shouldBe` bpGithubUsers bp
64+
31 when (bp' /= bp) $ error "bp' /= bp"
65 when (bp' /= bp) $ error "bp' /= bp"
32− bp2 <- updateBuildPlan pkgs bp
66+ bp2 <- updateBuildPlan plans bp
33 when (dropVersionRanges bp2 /= dropVersionRanges bp) $ error "bp2 /= bp"
67 when (dropVersionRanges bp2 /= dropVersionRanges bp) $ error "bp2 /= bp"
68+ checkBuildPlan bp
34 where
69 where
35 dropVersionRanges bp =
70 dropVersionRanges bp =
36 bp { bpPackages = map go $ bpPackages bp }
71 bp { bpPackages = map go $ bpPackages bp }
37 where
72 where
38 go pb = pb { ppConstraints = go' $ ppConstraints pb }
73 go pb = pb { ppConstraints = go' $ ppConstraints pb }
39 go' pc = pc { pcVersionRange = anyVersion }
74 go' pc = pc { pcVersionRange = anyVersion }
75+
76+-- | Make a package set from a convenient data structure.
77+makePackageSet
78+ :: [(String,[Int],[(String,VersionRange)])]
79+ -> BuildConstraints
80+ -> IO (Map PackageName PackagePlan)
81+makePackageSet ps _ =
82+ return $
83+ M.fromList $
84+ map
85+ (\(name,ver,deps) ->
86+ ( PackageName name
87+ , dummyPackage ver $
88+ M.fromList $
89+ map
90+ (\(dname,dver) ->
91+ ( PackageName dname
92+ , DepInfo {diComponents = S.fromList
93+ [CompLibrary]
94+ ,diRange = dver}))
95+ deps))
96+ ps
97+ where
98+ dummyPackage v deps =
99+ PackagePlan
100+ {ppVersion = Version v []
101+ ,ppGithubPings = mempty
102+ ,ppUsers = mempty
103+ ,ppConstraints =
104+ PackageConstraints
105+ {pcVersionRange = anyV
106+ ,pcMaintainer = Nothing
107+ ,pcTests = Don'tBuild
108+ ,pcHaddocks = Don'tBuild
109+ ,pcBuildBenchmarks = False
110+ ,pcFlagOverrides = mempty
111+ ,pcEnableLibProfile = False}
112+ ,ppDesc =
113+ SimpleDesc
114+ {sdPackages = deps
115+ ,sdTools = mempty
116+ ,sdProvidedExes = mempty
117+ ,sdModules = mempty}}
118+
119+-- | This exact version is required.
120+thisV :: [Int] -> VersionRange
121+thisV ver = thisVersion (Version ver [])
122+
123+-- | Accept any version.
124+anyV :: VersionRange
125+anyV = anyVersion
126+
127+-- | Test plan.
128+testBuildConstraints :: void -> IO BuildConstraints
129+testBuildConstraints _ =
130+ decodeFileEither
131+ (fpToString fp) >>=
132+ either throwIO toBC
133+ where fp = "test/test-build-constraints.yaml"
test/test-build-constraints.yamlnew file+20
@@ -0,0 +1,20 @@
1+packages:
2+ "Test":
3+ - foo
4+ - bar
5+
6+global-flags: []
7+
8+skipped-tests: []
9+expected-test-failures: []
10+expected-haddock-failures: []
11+skipped-benchmarks: []
12+skipped-profiling: []
13+
14+github-users:
15+ bar:
16+ - demo
17+
18+package-flags:
19+ foo:
20+ demo: true