git.iko.soy/stackage
on 508fefe help sign in
stackage/test/Stackage/BuildPlanSpec.hs
143 lines 5.2 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 {- Shouldn't be testing this actually
40 it "default package set checks ok" $
41 check defaultBuildConstraints getLatestAllowedPlans
42 -}
44-- | Checking should be considered a bad build plan.
45badBuildPlan :: (BuildConstraints -> IO (Map PackageName PackagePlan))
46 -> void
47 -> IO ()
48badBuildPlan m _ = do
49 mu <- try (check testBuildConstraints m)
50 case mu of
51 Left (_ :: BadBuildPlan) ->
52 return ()
53 Right () ->
54 error "Expected bad build plan."
56-- | Check build plan with the given package set getter.
57check :: (Manager -> IO BuildConstraints)
58 -> (BuildConstraints -> IO (Map PackageName PackagePlan))
59 -> IO ()
60check readPlanFile getPlans = withManager tlsManagerSettings $ \man -> do
61 bc <- readPlanFile man
62 plans <- getPlans bc
63 bp <- newBuildPlan plans bc
64 let bs = Y.encode bp
65 ebp' = Y.decodeEither bs
67 bp' <- either error return ebp'
69 let allPackages = Map.keysSet (bpPackages bp) ++ Map.keysSet (bpPackages bp')
70 forM_ allPackages $ \name ->
71 (name, lookup name (bpPackages bp')) `shouldBe`
72 (name, lookup name (bpPackages bp))
73 bpGithubUsers bp' `shouldBe` bpGithubUsers bp
75 when (bp' /= bp) $ error "bp' /= bp"
76 bp2 <- updateBuildPlan plans bp
77 when (dropVersionRanges bp2 /= dropVersionRanges bp) $ error "bp2 /= bp"
78 checkBuildPlan bp
79 where
80 dropVersionRanges bp =
81 bp { bpPackages = map go $ bpPackages bp }
82 where
83 go pb = pb { ppConstraints = go' $ ppConstraints pb }
84 go' pc = pc { pcVersionRange = anyVersion }
86-- | Make a package set from a convenient data structure.
87makePackageSet
88 :: [(String,[Int],[(String,VersionRange)])]
89 -> BuildConstraints
90 -> IO (Map PackageName PackagePlan)
91makePackageSet ps _ =
92 return $
93 M.fromList $
94 map
95 (\(name,ver,deps) ->
96 ( PackageName name
97 , dummyPackage ver $
98 M.fromList $
99 map
100 (\(dname,dver) ->
101 ( PackageName dname
102 , DepInfo {diComponents = S.fromList
103 [CompLibrary]
104 ,diRange = dver}))
105 deps))
106 ps
107 where
108 dummyPackage v deps =
109 PackagePlan
110 {ppVersion = Version v []
111 ,ppGithubPings = mempty
112 ,ppUsers = mempty
113 ,ppConstraints =
114 PackageConstraints
115 {pcVersionRange = anyV
116 ,pcMaintainer = Nothing
117 ,pcTests = Don'tBuild
118 ,pcHaddocks = Don'tBuild
119 ,pcBuildBenchmarks = False
120 ,pcFlagOverrides = mempty
121 ,pcEnableLibProfile = False}
122 ,ppDesc =
123 SimpleDesc
124 {sdPackages = deps
125 ,sdTools = mempty
126 ,sdProvidedExes = mempty
127 ,sdModules = mempty}}
129-- | This exact version is required.
130thisV :: [Int] -> VersionRange
131thisV ver = thisVersion (Version ver [])
133-- | Accept any version.
134anyV :: VersionRange
135anyV = anyVersion
137-- | Test plan.
138testBuildConstraints :: void -> IO BuildConstraints
139testBuildConstraints _ =
140 decodeFileEither
141 (fpToString fp) >>=
142 either throwIO toBC
143 where fp = "test/test-build-constraints.yaml"