git.iko.soy/stackage
on 4e156eb help sign in
stackage/test/Stackage/BuildPlanSpec.hs
141 lines 5.1 kB history raw
1{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}
3module Stackage.BuildPlanSpec (spec) where
5import qualified Data.Map as Map
6import qualified Data.Map.Strict as M
7import qualified Data.Set as S
8import Data.Yaml
9import qualified Data.Yaml as Y
10import Distribution.Version
11import Network.HTTP.Client
12import Network.HTTP.Client.TLS (tlsManagerSettings)
13import Stackage.BuildConstraints
14import Stackage.BuildPlan
15import Stackage.CheckBuildPlan
16import Stackage.PackageDescription
17import Stackage.Prelude
18import Stackage.UpdateBuildPlan
19import Test.Hspec
21spec :: Spec
22spec = 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 "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" $
40 check defaultBuildConstraints getLatestAllowedPlans
42-- | Checking should be considered a bad build plan.
43badBuildPlan :: (BuildConstraints -> IO (Map PackageName PackagePlan))
44 -> void
45 -> IO ()
46badBuildPlan m _ = do
47 mu <- try (check testBuildConstraints m)
48 case mu of
49 Left (_ :: BadBuildPlan) ->
50 return ()
51 Right () ->
52 error "Expected bad build plan."
54-- | Check build plan with the given package set getter.
55check :: (Manager -> IO BuildConstraints)
56 -> (BuildConstraints -> IO (Map PackageName PackagePlan))
57 -> IO ()
58check readPlanFile getPlans = withManager tlsManagerSettings $ \man -> do
59 bc <- readPlanFile man
60 plans <- getPlans bc
61 bp <- newBuildPlan plans bc
62 let bs = Y.encode bp
63 ebp' = Y.decodeEither bs
65 bp' <- either error return ebp'
67 let allPackages = Map.keysSet (bpPackages bp) ++ Map.keysSet (bpPackages bp')
68 forM_ allPackages $ \name ->
69 (name, lookup name (bpPackages bp')) `shouldBe`
70 (name, lookup name (bpPackages bp))
71 bpGithubUsers bp' `shouldBe` bpGithubUsers bp
73 when (bp' /= bp) $ error "bp' /= bp"
74 bp2 <- updateBuildPlan plans bp
75 when (dropVersionRanges bp2 /= dropVersionRanges bp) $ error "bp2 /= bp"
76 checkBuildPlan bp
77 where
78 dropVersionRanges bp =
79 bp { bpPackages = map go $ bpPackages bp }
80 where
81 go pb = pb { ppConstraints = go' $ ppConstraints pb }
82 go' pc = pc { pcVersionRange = anyVersion }
84-- | Make a package set from a convenient data structure.
85makePackageSet
86 :: [(String,[Int],[(String,VersionRange)])]
87 -> BuildConstraints
88 -> IO (Map PackageName PackagePlan)
89makePackageSet ps _ =
90 return $
91 M.fromList $
92 map
93 (\(name,ver,deps) ->
94 ( PackageName name
95 , dummyPackage ver $
96 M.fromList $
97 map
98 (\(dname,dver) ->
99 ( PackageName dname
100 , DepInfo {diComponents = S.fromList
101 [CompLibrary]
102 ,diRange = dver}))
103 deps))
104 ps
105 where
106 dummyPackage v deps =
107 PackagePlan
108 {ppVersion = Version v []
109 ,ppGithubPings = mempty
110 ,ppUsers = mempty
111 ,ppConstraints =
112 PackageConstraints
113 {pcVersionRange = anyV
114 ,pcMaintainer = Nothing
115 ,pcTests = Don'tBuild
116 ,pcHaddocks = Don'tBuild
117 ,pcBuildBenchmarks = False
118 ,pcFlagOverrides = mempty
119 ,pcEnableLibProfile = False}
120 ,ppDesc =
121 SimpleDesc
122 {sdPackages = deps
123 ,sdTools = mempty
124 ,sdProvidedExes = mempty
125 ,sdModules = mempty}}
127-- | This exact version is required.
128thisV :: [Int] -> VersionRange
129thisV ver = thisVersion (Version ver [])
131-- | Accept any version.
132anyV :: VersionRange
133anyV = anyVersion
135-- | Test plan.
136testBuildConstraints :: void -> IO BuildConstraints
137testBuildConstraints _ =
138 decodeFileEither
139 (fpToString fp) >>=
140 either throwIO toBC
141 where fp = "test/test-build-constraints.yaml"