@@ -1,22 +1,56 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}
23module Stackage.BuildPlanSpec (spec) where
34
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)
115import qualified Data.Map as Map
12−import Network.HTTP.Client (withManager)
13−import Network.HTTP.Client.TLS (tlsManagerSettings)
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
11+import Network.HTTP.Client
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
1420
1521spec :: Spec
16−spec = it "works" $ withManager tlsManagerSettings $ \man -> do
17− bc <- defaultBuildConstraints man
18− pkgs <- getLatestAllowedPlans bc
19− bp <- newBuildPlan pkgs bc
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 ()
50+check readPlanFile getPlans = withManager tlsManagerSettings $ \man -> do
51+ bc <- readPlanFile man
52+ plans <- getPlans bc
53+ bp <- newBuildPlan plans bc
2054 let bs = Y.encode bp
2155 ebp' = Y.decodeEither bs
2256
@@ -26,14 +60,74 @@ spec = it "works" $ withManager tlsManagerSettings $ \man -> do
2660 forM_ allPackages $ \name ->
2761 (name, lookup name (bpPackages bp')) `shouldBe`
2862 (name, lookup name (bpPackages bp))
29−
3063 bpGithubUsers bp' `shouldBe` bpGithubUsers bp
64+
3165 when (bp' /= bp) $ error "bp' /= bp"
32− bp2 <- updateBuildPlan pkgs bp
66+ bp2 <- updateBuildPlan plans bp
3367 when (dropVersionRanges bp2 /= dropVersionRanges bp) $ error "bp2 /= bp"
68+ checkBuildPlan bp
3469 where
3570 dropVersionRanges bp =
3671 bp { bpPackages = map go $ bpPackages bp }
3772 where
3873 go pb = pb { ppConstraints = go' $ ppConstraints pb }
3974 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"