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