git.iko.soy/stackage
on 76e893b help sign in
stackage/Stackage/BuildConstraints.hs
214 lines 8.5 kB history raw
1{-# LANGUAGE NoImplicitPrelude #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE TupleSections #-}
5-- | The constraints on package selection for a new build plan.
6module Stackage.BuildConstraints
7 ( BuildConstraints (..)
8 , PackageConstraints (..)
9 , TestState (..)
10 , SystemInfo (..)
11 , getSystemInfo
12 , defaultBuildConstraints
13 ) where
15import Control.Monad.Writer.Strict (execWriter, tell)
16import Data.Aeson
17import qualified Data.Map as Map
18import Data.Yaml (decodeEither', decodeFileEither)
19import Distribution.Package (Dependency (..))
20import Distribution.System (Arch, OS)
21import qualified Distribution.System
22import Distribution.Version (anyVersion)
23import Distribution.Version (anyVersion)
24import Filesystem (isFile)
25import Network.HTTP.Client (Manager, httpLbs, responseBody)
26import Stackage.CorePackages
27import Stackage.Prelude
29data TestState = ExpectSuccess
30 | ExpectFailure
31 | Don'tBuild -- ^ when the test suite will pull in things we don't want
32 deriving (Show, Eq, Ord, Bounded, Enum)
34testStateToText :: TestState -> Text
35testStateToText ExpectSuccess = "expect-success"
36testStateToText ExpectFailure = "expect-failure"
37testStateToText Don'tBuild = "do-not-build"
39instance ToJSON TestState where
40 toJSON = toJSON . testStateToText
41instance FromJSON TestState where
42 parseJSON = withText "TestState" $ \t ->
43 case lookup t states of
44 Nothing -> fail $ "Invalid state: " ++ unpack t
45 Just v -> return v
46 where
47 states = asHashMap $ mapFromList
48 $ map (\x -> (testStateToText x, x)) [minBound..maxBound]
50data SystemInfo = SystemInfo
51 { siGhcVersion :: Version
52 , siOS :: OS
53 , siArch :: Arch
54 , siCorePackages :: Map PackageName Version
55 , siCoreExecutables :: Set ExeName
56 }
57 deriving (Show, Eq, Ord)
58instance ToJSON SystemInfo where
59 toJSON SystemInfo {..} = object
60 [ "ghc-version" .= display siGhcVersion
61 , "os" .= display siOS
62 , "arch" .= display siArch
63 , "core-packages" .= Map.mapKeysWith const unPackageName (map display siCorePackages)
64 , "core-executables" .= siCoreExecutables
65 ]
66instance FromJSON SystemInfo where
67 parseJSON = withObject "SystemInfo" $ \o -> do
68 let helper name = (o .: name) >>= either (fail . show) return . simpleParse
69 siGhcVersion <- helper "ghc-version"
70 siOS <- helper "os"
71 siArch <- helper "arch"
72 siCorePackages <- (o .: "core-packages") >>= goPackages
73 siCoreExecutables <- o .: "core-executables"
74 return SystemInfo {..}
75 where
76 goPackages = either (fail . show) return
77 . mapM simpleParse
78 . Map.mapKeysWith const mkPackageName
80data BuildConstraints = BuildConstraints
81 { bcPackages :: Set PackageName
82 -- ^ This does not include core packages.
83 , bcPackageConstraints :: PackageName -> PackageConstraints
85 , bcSystemInfo :: SystemInfo
87 , bcGithubUsers :: Map Text (Set Text)
88 -- ^ map an account to set of pingees
89 }
91data PackageConstraints = PackageConstraints
92 { pcVersionRange :: VersionRange
93 , pcMaintainer :: Maybe Maintainer
94 , pcTests :: TestState
95 , pcHaddocks :: TestState
96 , pcBuildBenchmarks :: Bool
97 , pcFlagOverrides :: Map FlagName Bool
98 }
99 deriving (Show, Eq)
100instance ToJSON PackageConstraints where
101 toJSON PackageConstraints {..} = object $ addMaintainer
102 [ "version-range" .= display pcVersionRange
103 , "tests" .= pcTests
104 , "haddocks" .= pcHaddocks
105 , "build-benchmarks" .= pcBuildBenchmarks
106 , "flags" .= Map.mapKeysWith const unFlagName pcFlagOverrides
107 ]
108 where
109 addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer
110instance FromJSON PackageConstraints where
111 parseJSON = withObject "PackageConstraints" $ \o -> do
112 pcVersionRange <- (o .: "version-range")
113 >>= either (fail . show) return . simpleParse
114 pcTests <- o .: "tests"
115 pcHaddocks <- o .: "haddocks"
116 pcBuildBenchmarks <- o .: "build-benchmarks"
117 pcFlagOverrides <- Map.mapKeysWith const mkFlagName <$> o .: "flags"
118 pcMaintainer <- o .:? "maintainer"
119 return PackageConstraints {..}
121-- | The proposed plan from the requirements provided by contributors.
122--
123-- Checks the current directory for a build-constraints.yaml file and uses it
124-- if present. If not, downloads from Github.
125defaultBuildConstraints :: Manager -> IO BuildConstraints
126defaultBuildConstraints man = do
127 e <- isFile fp
128 if e
129 then decodeFileEither (fpToString fp) >>= either throwIO toBC
130 else httpLbs req man >>=
131 either throwIO toBC . decodeEither' . toStrict . responseBody
132 where
133 fp = "build-constraints.yaml"
134 req = "https://raw.githubusercontent.com/fpco/stackage/master/build-constraints.yaml"
136getSystemInfo :: IO SystemInfo
137getSystemInfo = do
138 siCorePackages <- getCorePackages
139 siCoreExecutables <- getCoreExecutables
140 siGhcVersion <- getGhcVersion
141 return SystemInfo {..}
142 where
143 -- FIXME consider not hard-coding the next two values
144 siOS = Distribution.System.Linux
145 siArch = Distribution.System.X86_64
147loadBuildConstraints fp = decodeFileEither fp >>= either throwIO toBC
149data ConstraintFile = ConstraintFile
150 { cfGlobalFlags :: Map FlagName Bool
151 , cfPackageFlags :: Map PackageName (Map FlagName Bool)
152 , cfSkippedTests :: Set PackageName
153 , cfExpectedTestFailures :: Set PackageName
154 , cfExpectedHaddockFailures :: Set PackageName
155 , cfSkippedBenchmarks :: Set PackageName
156 , cfPackages :: Map Maintainer (Vector Dependency)
157 , cfGithubUsers :: Map Text (Set Text)
158 }
160instance FromJSON ConstraintFile where
161 parseJSON = withObject "ConstraintFile" $ \o -> do
162 cfGlobalFlags <- goFlagMap <$> o .: "global-flags"
163 cfPackageFlags <- (goPackageMap . fmap goFlagMap) <$> o .: "package-flags"
164 cfSkippedTests <- getPackages o "skipped-tests"
165 cfExpectedTestFailures <- getPackages o "expected-test-failures"
166 cfExpectedHaddockFailures <- getPackages o "expected-haddock-failures"
167 cfSkippedBenchmarks <- getPackages o "skipped-benchmarks"
168 cfPackages <- o .: "packages"
169 >>= mapM (mapM toDep)
170 . Map.mapKeysWith const Maintainer
171 cfGithubUsers <- o .: "github-users"
172 return ConstraintFile {..}
173 where
174 goFlagMap = Map.mapKeysWith const FlagName
175 goPackageMap = Map.mapKeysWith const PackageName
176 getPackages o name = (setFromList . map PackageName) <$> o .: name
178 toDep :: Monad m => Text -> m Dependency
179 toDep = either (fail . show) return . simpleParse
181toBC :: ConstraintFile -> IO BuildConstraints
182toBC ConstraintFile {..} = do
183 bcSystemInfo <- getSystemInfo
184 return BuildConstraints {..}
185 where
186 combine (maintainer, range1) (_, range2) =
187 (maintainer, intersectVersionRanges range1 range2)
188 revmap = unionsWith combine $ ($ []) $ execWriter
189 $ forM_ (mapToList cfPackages)
190 $ \(maintainer, deps) -> forM_ deps
191 $ \(Dependency name range) ->
192 tell (singletonMap name (maintainer, range):)
194 bcPackages = Map.keysSet revmap
196 bcPackageConstraints name =
197 PackageConstraints {..}
198 where
199 mpair = lookup name revmap
200 pcMaintainer = fmap fst mpair
201 pcVersionRange = maybe anyVersion snd mpair
202 pcTests
203 | name `member` cfSkippedTests = Don'tBuild
204 | name `member` cfExpectedTestFailures = ExpectFailure
205 | otherwise = ExpectSuccess
206 pcBuildBenchmarks = name `notMember` cfSkippedBenchmarks
207 pcHaddocks
208 | name `member` cfExpectedHaddockFailures = ExpectFailure
210 | otherwise = ExpectSuccess
211 pcFlagOverrides = fromMaybe mempty (lookup name cfPackageFlags) ++
212 cfGlobalFlags
214 bcGithubUsers = cfGithubUsers