stackage 0.6.0.1 → 0.7.0.0
raw patch · 26 files changed
+28/−3518 lines, 26 filesdep +stackage-clidep +stackage-updatedep −Cabaldep −QuickCheckdep −aesondep ~base
Dependencies added: stackage-cli, stackage-update
Dependencies removed: Cabal, QuickCheck, aeson, async, bytestring, classy-prelude-conduit, conduit, conduit-extra, containers, data-default-class, directory, filepath, hspec, http-client, http-client-tls, http-conduit, mono-traversable, mtl, old-locale, optparse-applicative, process, semigroups, stackage, stm, streaming-commons, system-fileio, system-filepath, tar, temporary, text, time, transformers, unix-compat, utf8-string, xml-conduit, yaml, zlib
Dependency ranges changed: base
Files
- ChangeLog.md +4/−58
- LICENSE +8/−8
- README.md +2/−134
- Stackage/BuildConstraints.hs +0/−234
- Stackage/BuildPlan.hs +0/−214
- Stackage/CheckBuildPlan.hs +0/−162
- Stackage/CompleteBuild.hs +0/−329
- Stackage/CorePackages.hs +0/−53
- Stackage/Dummy.hs +3/−0
- Stackage/GhcPkg.hs +0/−104
- Stackage/GithubPings.hs +0/−36
- Stackage/InstallBuild.hs +0/−100
- Stackage/PackageDescription.hs +0/−200
- Stackage/PackageIndex.hs +0/−127
- Stackage/PerformBuild.hs +0/−555
- Stackage/Prelude.hs +0/−116
- Stackage/ServerBundle.hs +0/−271
- Stackage/UpdateBuildPlan.hs +0/−54
- Stackage/Upload.hs +0/−271
- app/stackage.hs +0/−195
- stackage.cabal +11/−93
- test/Spec.hs +0/−1
- test/Stackage/BuildPlanSpec.hs +0/−143
- test/Stackage/CorePackagesSpec.hs +0/−19
- test/Stackage/PackageIndexSpec.hs +0/−21
- test/test-build-constraints.yaml +0/−20
ChangeLog.md view
@@ -1,59 +1,5 @@-## 0.6.0--* Upload bundle V2 stuff--## 0.5.2--* Upload LTS to Hackage with the name LTSHaskell--## 0.5.1--* `loadBuildConstraints`-* More command line options--## 0.5.0--* Print "Still Alive" while checking, to avoid Travis timeouts-* Include `stackage upload-nightly` command-* Optional plan checking--## 0.4.0--* Command line uses optparse-applicative with additional options-* Library profiling support during build-* Remove cfGlobalFlags (just use package-specific flags)--## 0.3.1--* Added `justCheck` and `stackage check` command line.--## 0.3.0.1--Pre-fetch all packages from Hackage to catch Hackage downtime early.--## 0.3.0.0--* Return progress URL from uploadBundle--## 0.2.1.4--Generate a `core` file in bundles.--## 0.2.1.1--Run postBuild earlier to avoid problems from broken doc uploads.--## 0.2.1.0--* Use TLS manager (to download from Github)--## 0.2.0.0--* Minor fixes-* `pbGlobalInstall`--## 0.1.0.0+## 0.7.0.0 -First version of Stackage which is made available as its own package. The-codebase has been completely rewritten at this point, to be ready for generated-both Stackage Nightly and LTS Haskell distributions.+* First release of this incarnation of the stackage package. Previously, this+ package provided completely different functionality. That functionality has+ since moved to stackage-curator.
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2012 FP Complete, http://www.fpcomplete.com/+Copyright (c) 2015 FP Complete Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the@@ -8,13 +8,13 @@ permit persons to whom the Software is furnished to do so, subject to the following conditions: -The above copyright notice and this permission notice shall be-included in all copies or substantial portions of the Software.+The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE-LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION-OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION-WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
README.md view
@@ -1,134 +1,2 @@-stackage-========--"Stable Hackage," tools for creating a vetted set of packages from Hackage.--__NOTE__ This repository is for package authors to get their code into-Stackage. If you simply want to use Stackage as an end user, please follow the-instructions on [http://www.stackage.org/](http://www.stackage.org).--A note about the codebase: the goal is to minimize dependencies and have-the maximum range of supported compiler versions. Therefore, we avoid-anything "complicated." For example, instead of using the text package,-we use Strings everywhere.--Get your package included----------------------------In order to get your package included in the set of stable packages, you should-send a pull request against this repository. In the [`build-constraints.yaml`](https://github.com/fpco/stackage/blob/master/build-constraints.yaml) file,-there's a section called `packages`. In general, to add a set of-packages, you would add:-- "My Name myemail@example.com @mygithubuser":- - package1- - package2- - package3--You can follow the examples of the other sets of packages in that function.-Once you've done this, you can send a pull request to get your package-included.--__NOTE__: In order to ease the process of adding new packages, we no longer-require new submissions to be tested on your own system before sending a pull-request. If you believe your package works with the newest versions of all-dependencies, you may send a pull request without testing first.--You should also read the [maintainers-agreement](https://github.com/fpco/stackage/wiki/Maintainers-Agreement).--Build the package set------------------------Generally, building the package set should be done only by the Jenkins machine-or by the official maintainers, as the process does require quite a bit of-setup on the local machine. That said, you'll likely be able to get a stable-build by running:-- cabal update- cabal install stackage- stackage nightly--### Docker--Note: This method is currently considered experimental.--If you'd like to check a build plan, or perform an entire build, without-specially configuring your system, Docker may be a good approach. To check if-some modifications to `build-constraints.yaml` are valid, try the following:--1. Create a local clone of the `stackage` repo-2. Make modifications to your local `build-constraints.yaml`-3. Inside the `stackage` working directory, run the following:-- ```- $ docker run -it --rm -v $(pwd):/stackage -w /stackage snoyberg/stackage /bin/bash -c 'cabal update && stackage check'- ```--Similarly, if you'd like to perform an entire build, you can replace the last step with:--```-$ docker run -it --rm -v $(pwd):/stackage -w /stackage snoyberg/stackage /bin/bash -c 'cabal update && stackage nightly --skip-upload'-```--## Processing--The following describes at a high level the series of steps for processing--### Nightlies--1. Get list of core packages-2. Get build constraints from list of maintained packages-3. Load up package index-4. Calculate build plan using newest versions of packages-5. Write out a YAML file with complete build plan-6. Verify that the build plan can be compiled-7. Perform the build--### LTS--1. Load up most recent build plan-2. Convert build plan into constraints for next build-3. Continue from step (3) above--## Code explanation--We start off with *constraints*. Constraints state things like "package X has a-given version range," who the maintainer is for a package, the description of-the system/compiler being used, etc. `BuildConstraints` describes the build as-a whole, whereas `PackageConstraints` describes the constraints on an-individual package.--There are two primary ways of getting a `BuildConstraints`.-`defaultBuildConstraints` inspects the first GHC in the PATH environment variable to-determine GHC version, core packages, core tools, etc. It then uses the-`Stackage.Config` module to extract information on additional packages to be-installed. The secondary approach is in `Stackage2.UpdateBuildPlan`, which will be-discussed later.--`BuildConstraints` does not specify a build completely. That is given by a-`BuildPlan`, which is similarly broken down into `BuildPlan` and `PackagePlan`.-In order to get a `BuildPlan`, we need two pieces of information: the-`BuildConstraints`, and a package index. The package index (usually downloaded-from Hackage) is a collection of all of the cabal files available.--By applying a `BuildConstraints` to a package index (via `newBuildPlan`), we-get a proposed `BuildPlan`. There is no guarantee that this `BuildPlan` is-valid. To validate it, we use `checkBuildPlan`. A `BuildPlan` is an instance of-both `ToJSON` and `FromJSON`, and therefore can be serialized to a file for-later use.--When dealing with LTS Haskell, we want to be able to take a `BuildPlan`, and-update to a newer `BuildPlan` that keeps all packages at the same major-version. `updateBuildConstraints` turns a `BuildPlan` into a new-`BuildConstraints` with that restriction, and `updateBuildPlan` applies-`newBuildPlan` to that result. As mentioned previously: this is *not* a-validated result, and therefore `checkBuildPlan` must be used.--A `BuildPlan` can be acted on. This is done to check that all packages compile-together, run relevant test suites, test Haddock documentation is correct, and-produce as artifacts both a self-contained GHC binary package database and a-set of Haddock documentation. (Not yet implemented.)--A `BuildPlan` may be converted into a bundle to be uploaded to Stackage Server.-(Not yet implemented.)+This is a dummy wrapper package, forcing installation of other packages which+provide real functionality.
− Stackage/BuildConstraints.hs
@@ -1,234 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}--- | The constraints on package selection for a new build plan.-module Stackage.BuildConstraints- ( BuildConstraints (..)- , PackageConstraints (..)- , TestState (..)- , SystemInfo (..)- , getSystemInfo- , defaultBuildConstraints- , toBC- , BuildConstraintsSource (..)- , loadBuildConstraints- ) where--import Control.Monad.Writer.Strict (execWriter, tell)-import Data.Aeson-import qualified Data.Map as Map-import Data.Yaml (decodeEither', decodeFileEither)-import Distribution.Package (Dependency (..))-import Distribution.System (Arch, OS)-import qualified Distribution.System-import Distribution.Version (anyVersion)-import Filesystem (isFile)-import Network.HTTP.Client (Manager, httpLbs, responseBody, Request)-import Stackage.CorePackages-import Stackage.Prelude--data TestState = ExpectSuccess- | ExpectFailure- | Don'tBuild -- ^ when the test suite will pull in things we don't want- deriving (Show, Eq, Ord, Bounded, Enum)--testStateToText :: TestState -> Text-testStateToText ExpectSuccess = "expect-success"-testStateToText ExpectFailure = "expect-failure"-testStateToText Don'tBuild = "do-not-build"--instance ToJSON TestState where- toJSON = toJSON . testStateToText-instance FromJSON TestState where- parseJSON = withText "TestState" $ \t ->- case lookup t states of- Nothing -> fail $ "Invalid state: " ++ unpack t- Just v -> return v- where- states = asHashMap $ mapFromList- $ map (\x -> (testStateToText x, x)) [minBound..maxBound]--data SystemInfo = SystemInfo- { siGhcVersion :: Version- , siOS :: OS- , siArch :: Arch- , siCorePackages :: Map PackageName Version- , siCoreExecutables :: Set ExeName- }- deriving (Show, Eq, Ord)-instance ToJSON SystemInfo where- toJSON SystemInfo {..} = object- [ "ghc-version" .= display siGhcVersion- , "os" .= display siOS- , "arch" .= display siArch- , "core-packages" .= Map.mapKeysWith const unPackageName (map display siCorePackages)- , "core-executables" .= siCoreExecutables- ]-instance FromJSON SystemInfo where- parseJSON = withObject "SystemInfo" $ \o -> do- let helper name = (o .: name) >>= either (fail . show) return . simpleParse- siGhcVersion <- helper "ghc-version"- siOS <- helper "os"- siArch <- helper "arch"- siCorePackages <- (o .: "core-packages") >>= goPackages- siCoreExecutables <- o .: "core-executables"- return SystemInfo {..}- where- goPackages = either (fail . show) return- . mapM simpleParse- . Map.mapKeysWith const mkPackageName--data BuildConstraints = BuildConstraints- { bcPackages :: Set PackageName- -- ^ This does not include core packages.- , bcPackageConstraints :: PackageName -> PackageConstraints-- , bcSystemInfo :: SystemInfo-- , bcGithubUsers :: Map Text (Set Text)- -- ^ map an account to set of pingees- }--data PackageConstraints = PackageConstraints- { pcVersionRange :: VersionRange- , pcMaintainer :: Maybe Maintainer- , pcTests :: TestState- , pcHaddocks :: TestState- , pcBuildBenchmarks :: Bool- , pcFlagOverrides :: Map FlagName Bool- , pcEnableLibProfile :: Bool- }- deriving (Show, Eq)-instance ToJSON PackageConstraints where- toJSON PackageConstraints {..} = object $ addMaintainer- [ "version-range" .= display pcVersionRange- , "tests" .= pcTests- , "haddocks" .= pcHaddocks- , "build-benchmarks" .= pcBuildBenchmarks- , "flags" .= Map.mapKeysWith const unFlagName pcFlagOverrides- , "library-profiling" .= pcEnableLibProfile- ]- where- addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer-instance FromJSON PackageConstraints where- parseJSON = withObject "PackageConstraints" $ \o -> do- pcVersionRange <- (o .: "version-range")- >>= either (fail . show) return . simpleParse- pcTests <- o .: "tests"- pcHaddocks <- o .: "haddocks"- pcBuildBenchmarks <- o .: "build-benchmarks"- pcFlagOverrides <- Map.mapKeysWith const mkFlagName <$> o .: "flags"- pcMaintainer <- o .:? "maintainer"- pcEnableLibProfile <- fmap (fromMaybe True) (o .:? "library-profiling")- return PackageConstraints {..}---- | The proposed plan from the requirements provided by contributors.------ Checks the current directory for a build-constraints.yaml file and uses it--- if present. If not, downloads from Github.-defaultBuildConstraints :: Manager -> IO BuildConstraints-defaultBuildConstraints = loadBuildConstraints BCSDefault--data BuildConstraintsSource- = BCSDefault- | BCSFile FilePath- | BCSWeb Request- deriving (Show)--loadBuildConstraints :: BuildConstraintsSource -> Manager -> IO BuildConstraints-loadBuildConstraints bcs man = do- case bcs of- BCSDefault -> do- e <- isFile fp0- if e- then loadFile fp0- else loadReq req0- BCSFile fp -> loadFile fp- BCSWeb req -> loadReq req- where- fp0 = "build-constraints.yaml"- req0 = "https://raw.githubusercontent.com/fpco/stackage/master/build-constraints.yaml"-- loadFile fp = decodeFileEither (fpToString fp) >>= either throwIO toBC- loadReq req = httpLbs req man >>=- either throwIO toBC . decodeEither' . toStrict . responseBody---getSystemInfo :: IO SystemInfo-getSystemInfo = do- siCorePackages <- getCorePackages- siCoreExecutables <- getCoreExecutables- siGhcVersion <- getGhcVersion- return SystemInfo {..}- where- -- FIXME consider not hard-coding the next two values- siOS = Distribution.System.Linux- siArch = Distribution.System.X86_64--data ConstraintFile = ConstraintFile- { cfPackageFlags :: Map PackageName (Map FlagName Bool)- , cfSkippedTests :: Set PackageName- , cfExpectedTestFailures :: Set PackageName- , cfExpectedHaddockFailures :: Set PackageName- , cfSkippedBenchmarks :: Set PackageName- , cfPackages :: Map Maintainer (Vector Dependency)- , cfGithubUsers :: Map Text (Set Text)- , cfSkippedLibProfiling :: Set PackageName- }--instance FromJSON ConstraintFile where- parseJSON = withObject "ConstraintFile" $ \o -> do- cfPackageFlags <- (goPackageMap . fmap goFlagMap) <$> o .: "package-flags"- cfSkippedTests <- getPackages o "skipped-tests"- cfExpectedTestFailures <- getPackages o "expected-test-failures"- cfExpectedHaddockFailures <- getPackages o "expected-haddock-failures"- cfSkippedBenchmarks <- getPackages o "skipped-benchmarks"- cfSkippedLibProfiling <- getPackages o "skipped-profiling"- cfPackages <- o .: "packages"- >>= mapM (mapM toDep)- . Map.mapKeysWith const Maintainer- cfGithubUsers <- o .: "github-users"- return ConstraintFile {..}- where- goFlagMap = Map.mapKeysWith const FlagName- goPackageMap = Map.mapKeysWith const PackageName- getPackages o name = (setFromList . map PackageName) <$> o .: name-- toDep :: Monad m => Text -> m Dependency- toDep = either (fail . show) return . simpleParse--toBC :: ConstraintFile -> IO BuildConstraints-toBC ConstraintFile {..} = do- bcSystemInfo <- getSystemInfo- return BuildConstraints {..}- where- combine (maintainer, range1) (_, range2) =- (maintainer, intersectVersionRanges range1 range2)- revmap = unionsWith combine $ ($ []) $ execWriter- $ forM_ (mapToList cfPackages)- $ \(maintainer, deps) -> forM_ deps- $ \(Dependency name range) ->- tell (singletonMap name (maintainer, range):)-- bcPackages = Map.keysSet revmap-- bcPackageConstraints name =- PackageConstraints {..}- where- mpair = lookup name revmap- pcMaintainer = fmap fst mpair- pcVersionRange = maybe anyVersion snd mpair- pcEnableLibProfile = not (name `member` cfSkippedLibProfiling)- pcTests- | name `member` cfSkippedTests = Don'tBuild- | name `member` cfExpectedTestFailures = ExpectFailure- | otherwise = ExpectSuccess- pcBuildBenchmarks = name `notMember` cfSkippedBenchmarks- pcHaddocks- | name `member` cfExpectedHaddockFailures = ExpectFailure-- | otherwise = ExpectSuccess- pcFlagOverrides = fromMaybe mempty $ lookup name cfPackageFlags-- bcGithubUsers = cfGithubUsers
− Stackage/BuildPlan.hs
@@ -1,214 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}--- | Representation of a concrete build plan, and how to generate a new one--- based on constraints.-module Stackage.BuildPlan- ( BuildPlan (..)- , PackagePlan (..)- , newBuildPlan- , makeToolMap- , getLatestAllowedPlans- ) where--import Control.Monad.State.Strict (execState, get, put)-import Data.Aeson-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Distribution.Compiler-import Distribution.PackageDescription-import Stackage.BuildConstraints-import Stackage.GithubPings-import Stackage.PackageDescription-import Stackage.PackageIndex-import Stackage.Prelude--data BuildPlan = BuildPlan- { bpSystemInfo :: SystemInfo- , bpTools :: Vector (PackageName, Version)- , bpPackages :: Map PackageName PackagePlan- , bpGithubUsers :: Map Text (Set Text)- }- deriving (Show, Eq)--instance ToJSON BuildPlan where- toJSON BuildPlan {..} = object- [ "system-info" .= bpSystemInfo- , "tools" .= map goTool bpTools- , "packages" .= Map.mapKeysWith const unPackageName bpPackages- , "github-users" .= bpGithubUsers- ]- where- goTool (k, v) = object- [ "name" .= display k- , "version" .= display v- ]-instance FromJSON BuildPlan where- parseJSON = withObject "BuildPlan" $ \o -> do- bpSystemInfo <- o .: "system-info"- bpTools <- (o .: "tools") >>= mapM goTool- bpPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages")- bpGithubUsers <- o .:? "github-users" .!= mempty- return BuildPlan {..}- where- goTool = withObject "Tool" $ \o -> (,)- <$> ((o .: "name") >>=- either (fail . show) return . simpleParse . asText)- <*> ((o .: "version") >>=- either (fail . show) return . simpleParse . asText)--data PackagePlan = PackagePlan- { ppVersion :: Version- , ppGithubPings :: Set Text- , ppUsers :: Set PackageName- , ppConstraints :: PackageConstraints- , ppDesc :: SimpleDesc- }- deriving (Show, Eq)--instance ToJSON PackagePlan where- toJSON PackagePlan {..} = object- [ "version" .= asText (display ppVersion)- , "github-pings" .= ppGithubPings- , "users" .= map unPackageName (unpack ppUsers)- , "constraints" .= ppConstraints- , "description" .= ppDesc- ]-instance FromJSON PackagePlan where- parseJSON = withObject "PackageBuild" $ \o -> do- ppVersion <- o .: "version"- >>= either (fail . show) return- . simpleParse . asText- ppGithubPings <- o .:? "github-pings" .!= mempty- ppUsers <- Set.map PackageName <$> (o .:? "users" .!= mempty)- ppConstraints <- o .: "constraints"- ppDesc <- o .: "description"- return PackagePlan {..}---- | Make a build plan given these package set and build constraints.-newBuildPlan :: MonadIO m => Map PackageName PackagePlan -> BuildConstraints -> m BuildPlan-newBuildPlan packagesOrig bc@BuildConstraints {..} = liftIO $ do- let toolMap = makeToolMap packagesOrig- packages = populateUsers $ removeUnincluded bc toolMap packagesOrig- toolNames :: [ExeName]- toolNames = concatMap (Map.keys . sdTools . ppDesc) packages- tools <- topologicalSortTools toolMap $ mapFromList $ do- exeName <- toolNames- guard $ exeName `notMember` siCoreExecutables- packageName <- maybe mempty setToList $ lookup exeName toolMap- packagePlan <- maybeToList $ lookup packageName packagesOrig- return (packageName, packagePlan)- -- FIXME topologically sort packages? maybe just leave that to the build phase- return BuildPlan- { bpSystemInfo = bcSystemInfo- , bpTools = tools- , bpPackages = packages- , bpGithubUsers = bcGithubUsers- }- where- SystemInfo {..} = bcSystemInfo--makeToolMap :: Map PackageName PackagePlan- -> Map ExeName (Set PackageName)-makeToolMap =- unionsWith (++) . map go . mapToList- where- go (packageName, pp) =- foldMap go' $ sdProvidedExes $ ppDesc pp- where- go' exeName = singletonMap exeName (singletonSet packageName)--topologicalSortTools :: MonadThrow m- => Map ExeName (Set PackageName)- -> Map PackageName PackagePlan- -> m (Vector (PackageName, Version))-topologicalSortTools toolMap = topologicalSort- ppVersion- (concatMap (fromMaybe mempty . flip lookup toolMap) . Map.keys . sdTools . ppDesc)---- | Include only packages which are dependencies of the required packages and--- their build tools.-removeUnincluded :: BuildConstraints- -> Map ExeName (Set PackageName)- -> Map PackageName PackagePlan- -> Map PackageName PackagePlan-removeUnincluded BuildConstraints {..} toolMap orig =- mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig- where- SystemInfo {..} = bcSystemInfo-- included :: Set PackageName- included = flip execState mempty $ mapM_ add bcPackages-- add name = do- inc <- get- when (name `notMember` inc) $ do- put $ insertSet name inc- case lookup name orig of- Nothing -> return ()- Just pb -> do- mapM_ add $ Map.keys $ sdPackages $ ppDesc pb- forM_ (Map.keys $ sdTools $ ppDesc pb) $- \exeName -> when (exeName `notMember` siCoreExecutables)- $ mapM_ add $ fromMaybe mempty $ lookup exeName toolMap--populateUsers :: Map PackageName PackagePlan- -> Map PackageName PackagePlan-populateUsers orig =- mapWithKey go orig- where- go name pb = pb { ppUsers = foldMap (go2 name) (mapToList orig) }-- go2 dep (user, pb)- | dep `member` sdPackages (ppDesc pb) = singletonSet user- | otherwise = mempty---- | Check whether the given package/version combo meets the constraints--- currently in place.-isAllowed :: BuildConstraints- -> PackageName -> Version -> Bool-isAllowed bc = \name version ->- case lookup name $ siCorePackages $ bcSystemInfo bc of- Just _ -> False -- never reinstall a core package- Nothing -> withinRange version $ pcVersionRange $ bcPackageConstraints bc name--mkPackagePlan :: MonadThrow m- => BuildConstraints- -> GenericPackageDescription- -> m PackagePlan-mkPackagePlan bc gpd = do- ppDesc <- toSimpleDesc CheckCond {..} gpd- return PackagePlan {..}- where- PackageIdentifier name ppVersion = package $ packageDescription gpd- ppGithubPings = getGithubPings bc gpd- ppConstraints = bcPackageConstraints bc name- ppUsers = mempty -- must be filled in later-- ccPackageName = name- ccOS = siOS- ccArch = siArch- ccCompilerFlavor = Distribution.Compiler.GHC- ccCompilerVersion = siGhcVersion- ccFlags = flags- ccIncludeTests = pcTests ppConstraints /= Don'tBuild- ccIncludeBenchmarks = pcBuildBenchmarks ppConstraints-- SystemInfo {..} = bcSystemInfo bc-- overrides = pcFlagOverrides ppConstraints- getFlag MkFlag {..} =- (flagName, fromMaybe flagDefault $ lookup flagName overrides)- flags = mapFromList $ map getFlag $ genPackageFlags gpd--getLatestAllowedPlans :: MonadIO m => BuildConstraints -> m (Map PackageName PackagePlan)-getLatestAllowedPlans bc =- getLatestDescriptions- (isAllowed bc)- (mkPackagePlan bc)
− Stackage/CheckBuildPlan.hs
@@ -1,162 +0,0 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-}--- | Confirm that a build plan has a consistent set of dependencies.-module Stackage.CheckBuildPlan- ( checkBuildPlan- , BadBuildPlan- ) where--import Control.Monad.Writer.Strict (Writer, execWriter, tell)-import qualified Data.Map.Strict as M-import qualified Data.Text as T-import Stackage.BuildConstraints-import Stackage.BuildPlan-import Stackage.PackageDescription-import Stackage.Prelude---- | Check the build plan for missing deps, wrong versions, etc.-checkBuildPlan :: (MonadThrow m) => BuildPlan -> m ()-checkBuildPlan BuildPlan {..}- | null errs' = return ()- | otherwise = throwM errs- where- allPackages = map (,mempty) (siCorePackages bpSystemInfo) ++- map (ppVersion &&& M.keys . M.filter libAndExe . sdPackages . ppDesc) bpPackages- errs@(BadBuildPlan errs') =- execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages- -- Only looking at libraries and executables, benchmarks and tests- -- are allowed to create cycles (e.g. test-framework depends on- -- text, which uses test-framework in its test-suite).- libAndExe (DepInfo cs _) = any (flip elem [CompLibrary,CompExecutable]) cs---- | For a given package name and plan, check that its dependencies are:------ 1. Existent (existing in the provided package map)--- 2. Within version range--- 3. Check for dependency cycles.-checkDeps :: Map PackageName (Version,[PackageName])- -> (PackageName, PackagePlan)- -> Writer BadBuildPlan ()-checkDeps allPackages (user, pb) =- mapM_ go $ mapToList $ sdPackages $ ppDesc pb- where- go (dep, diRange -> range) =- case lookup dep allPackages of- Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap- Just (version,deps)- | version `withinRange` range ->- occursCheck allPackages- (\d v ->- tell $ BadBuildPlan $ singletonMap- (d,v)- errMap)- dep- deps- []- | otherwise -> tell $ BadBuildPlan $ singletonMap- (dep, Just version)- errMap- where- errMap = singletonMap pu range- pu = PkgUser- { puName = user- , puVersion = ppVersion pb- , puMaintainer = pcMaintainer $ ppConstraints pb- , puGithubPings = ppGithubPings pb- }---- | Check whether the package(s) occurs within its own dependency--- tree.-occursCheck- :: Monad m- => Map PackageName (Version,[PackageName])- -- ^ All packages.- -> (PackageName -> Maybe Version -> m ())- -- ^ Report an erroneous package.- -> PackageName- -- ^ Starting package to check for cycles in.- -> [PackageName]- -- ^ Dependencies of the package.- -> [PackageName]- -- ^ Previously seen packages up the dependency tree.- -> m ()-occursCheck allPackages reportError =- go- where- go pkg deps seen =- case find (flip elem seen) deps of- Just cyclic ->- reportError cyclic $- fmap fst (lookup cyclic allPackages)- Nothing ->- forM_ deps $- \pkg' ->- case lookup pkg' allPackages of- Just (_v,deps')- | pkg' /= pkg -> go pkg' deps' seen'- _ -> return ()- where seen' = pkg : seen--data PkgUser = PkgUser- { puName :: PackageName- , puVersion :: Version- , puMaintainer :: Maybe Maintainer- , puGithubPings :: Set Text- }- deriving (Eq, Ord)--pkgUserShow1 :: PkgUser -> Text-pkgUserShow1 PkgUser {..} = concat- [ display puName- , "-"- , display puVersion- ]--pkgUserShow2 :: PkgUser -> Text-pkgUserShow2 PkgUser {..} = unwords- $ (maybe "No maintainer" unMaintainer puMaintainer ++ ".")- : map (cons '@') (setToList puGithubPings)--newtype BadBuildPlan =- BadBuildPlan (Map (PackageName, Maybe Version) (Map PkgUser VersionRange))- deriving Typeable-instance Exception BadBuildPlan-instance Show BadBuildPlan where- show (BadBuildPlan errs) =- unpack $ concatMap go $ mapToList errs- where- go ((dep, mdepVer), users) = unlines- $ ""- : showDepVer dep mdepVer- : map showUser (mapToList users)-- showDepVer :: PackageName -> Maybe Version -> Text- showDepVer dep Nothing = display dep ++ " (not present) depended on by:"- showDepVer dep (Just version) = concat- [ display dep- , "-"- , display version- , " depended on by:"- ]-- showUser :: (PkgUser, VersionRange) -> Text- showUser (pu, range) = concat- [ "- "- , pkgUserShow1 pu- , " ("- -- add a space after < to avoid confusing Markdown processors (like- -- Github's issue tracker)- , T.replace "<" "< " $ display range- , "). "- , pkgUserShow2 pu- ]--instance Monoid BadBuildPlan where- mempty = BadBuildPlan mempty- mappend (BadBuildPlan x) (BadBuildPlan y) =- BadBuildPlan $ unionWith (unionWith intersectVersionRanges) x y
− Stackage/CompleteBuild.hs
@@ -1,329 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-module Stackage.CompleteBuild- ( BuildType (..)- , BumpType (..)- , BuildFlags (..)- , completeBuild- , justCheck- , justUploadNightly- , getStackageAuthToken- ) where--import Control.Concurrent (threadDelay)-import Control.Concurrent.Async (withAsync)-import Data.Default.Class (def)-import Data.Semigroup (Max (..), Option (..))-import Data.Text.Read (decimal)-import Data.Time-import Data.Yaml (decodeFileEither, encodeFile)-import Network.HTTP.Client-import Network.HTTP.Client.TLS (tlsManagerSettings)-import Stackage.BuildConstraints-import Stackage.BuildPlan-import Stackage.CheckBuildPlan-import Stackage.PerformBuild-import Stackage.Prelude-import Stackage.ServerBundle-import Stackage.UpdateBuildPlan-import Stackage.Upload-import System.Environment (lookupEnv)-import System.IO (BufferMode (LineBuffering), hSetBuffering)---- | Flags passed in from the command line.-data BuildFlags = BuildFlags- { bfEnableTests :: !Bool- , bfEnableHaddock :: !Bool- , bfDoUpload :: !Bool- , bfEnableLibProfile :: !Bool- , bfEnableExecDyn :: !Bool- , bfVerbose :: !Bool- , bfSkipCheck :: !Bool- , bfUploadV2 :: !Bool- } deriving (Show)--data BuildType = Nightly | LTS BumpType- deriving (Show, Read, Eq, Ord)--data BumpType = Major | Minor- deriving (Show, Read, Eq, Ord)--data Settings = Settings- { plan :: BuildPlan- , planFile :: FilePath- , buildDir :: FilePath- , logDir :: FilePath- , title :: Text -> Text -- ^ GHC version -> title- , slug :: Text- , setArgs :: Text -> UploadBundle -> UploadBundle- , postBuild :: IO ()- , distroName :: Text -- ^ distro name on Hackage- , snapshotType :: SnapshotType- , bundleDest :: FilePath- }--nightlyPlanFile :: Text -- ^ day- -> FilePath-nightlyPlanFile day = fpFromText ("nightly-" ++ day) <.> "yaml"--nightlySettings :: Text -- ^ day- -> BuildPlan- -> Settings-nightlySettings day plan' = Settings- { planFile = nightlyPlanFile day- , buildDir = fpFromText $ "builds/nightly"- , logDir = fpFromText $ "logs/stackage-nightly-" ++ day- , title = \ghcVer -> concat- [ "Stackage Nightly "- , day- , ", GHC "- , ghcVer- ]- , slug = slug'- , setArgs = \ghcVer ub -> ub { ubNightly = Just ghcVer }- , plan = plan'- , postBuild = return ()- , distroName = "Stackage"- , snapshotType = STNightly- , bundleDest = fpFromText $ "stackage-nightly-" ++ day ++ ".bundle"- }- where- slug' = "nightly-" ++ day--getSettings :: Manager -> BuildType -> IO Settings-getSettings man Nightly = do- day <- tshow . utctDay <$> getCurrentTime- bc <- defaultBuildConstraints man- pkgs <- getLatestAllowedPlans bc- plan' <- newBuildPlan pkgs bc- return $ nightlySettings day plan'-getSettings man (LTS bumpType) = do- Option mlts <- fmap (fmap getMax) $ runResourceT- $ sourceDirectory "."- $$ foldMapC (Option . fmap Max . parseLTSVer . filename)-- (new, plan') <- case bumpType of- Major -> do- let new =- case mlts of- Nothing -> LTSVer 0 0- Just (LTSVer x _) -> LTSVer (x + 1) 0- bc <- defaultBuildConstraints man- pkgs <- getLatestAllowedPlans bc- plan' <- newBuildPlan pkgs bc- return (new, plan')- Minor -> do- old <- maybe (error "No LTS plans found in current directory") return mlts- oldplan <- decodeFileEither (fpToString $ renderLTSVer old)- >>= either throwM return- let new = incrLTSVer old- let bc = updateBuildConstraints oldplan- pkgs <- getLatestAllowedPlans bc- plan' <- newBuildPlan pkgs bc- return (new, plan')-- let newfile = renderLTSVer new-- return Settings- { planFile = newfile- , buildDir = fpFromText $ "builds/lts"- , logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new- , title = \ghcVer -> concat- [ "LTS Haskell "- , tshow new- , ", GHC "- , ghcVer- ]- , slug = "lts-" ++ tshow new- , setArgs = \_ ub -> ub { ubLTS = Just $ tshow new }- , plan = plan'- , postBuild = do- let git args = withCheckedProcess- (proc "git" args) $ \ClosedStream Inherited Inherited ->- return ()- putStrLn "Committing new LTS file to Git"- git ["add", fpToString newfile]- git ["commit", "-m", "Added new LTS release: " ++ show new]- putStrLn "Pushing to Git repository"- git ["push"]- , distroName = "LTSHaskell"- , snapshotType =- case new of- LTSVer x y -> STLTS x y- , bundleDest = fpFromText $ "stackage-lts-" ++ tshow new ++ ".bundle"- }--data LTSVer = LTSVer !Int !Int- deriving (Eq, Ord)-instance Show LTSVer where- show (LTSVer x y) = concat [show x, ".", show y]-incrLTSVer :: LTSVer -> LTSVer-incrLTSVer (LTSVer x y) = LTSVer x (y + 1)--parseLTSVer :: FilePath -> Maybe LTSVer-parseLTSVer fp = do- w <- stripPrefix "lts-" $ fpToText fp- x <- stripSuffix ".yaml" w- Right (major, y) <- Just $ decimal x- z <- stripPrefix "." y- Right (minor, "") <- Just $ decimal z- return $ LTSVer major minor-renderLTSVer :: LTSVer -> FilePath-renderLTSVer lts = fpFromText $ concat- [ "lts-"- , tshow lts- , ".yaml"- ]---- | Just print a message saying "still alive" every minute, to appease Travis.-stillAlive :: IO () -> IO ()-stillAlive inner =- withAsync (printer 1) $ const inner- where- printer i = forever $ do- threadDelay 60000000- putStrLn $ "Still alive: " ++ tshow i- printer $! i + 1---- | Generate and check a new build plan, but do not execute it.------ Since 0.3.1-justCheck :: IO ()-justCheck = stillAlive $ withManager tlsManagerSettings $ \man -> do- putStrLn "Loading build constraints"- bc <- defaultBuildConstraints man-- putStrLn "Creating build plan"- plans <- getLatestAllowedPlans bc- plan <- newBuildPlan plans bc-- putStrLn $ "Writing build plan to check-plan.yaml"- encodeFile "check-plan.yaml" plan-- putStrLn "Checking plan"- checkBuildPlan plan-- putStrLn "Plan seems valid!"--getPerformBuild :: BuildFlags -> Settings -> PerformBuild-getPerformBuild buildFlags Settings {..} = PerformBuild- { pbPlan = plan- , pbInstallDest = buildDir- , pbLogDir = logDir- , pbLog = hPut stdout- , pbJobs = 8- , pbGlobalInstall = False- , pbEnableTests = bfEnableTests buildFlags- , pbEnableHaddock = bfEnableHaddock buildFlags- , pbEnableLibProfiling = bfEnableLibProfile buildFlags- , pbEnableExecDyn = bfEnableExecDyn buildFlags- , pbVerbose = bfVerbose buildFlags- , pbAllowNewer = bfSkipCheck buildFlags- }---- | Make a complete plan, build, test and upload bundle, docs and--- distro.-completeBuild :: BuildType -> BuildFlags -> IO ()-completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do- hSetBuffering stdout LineBuffering-- putStrLn $ "Loading settings for: " ++ tshow buildType- settings@Settings {..} <- getSettings man buildType-- putStrLn $ "Writing build plan to: " ++ fpToText planFile- encodeFile (fpToString planFile) plan-- if bfSkipCheck buildFlags- then putStrLn "Skipping build plan check"- else do- putStrLn "Checking build plan"- checkBuildPlan plan-- putStrLn "Performing build"- let pb = getPerformBuild buildFlags settings- performBuild pb >>= mapM_ putStrLn-- putStrLn $ "Creating bundle (v2) at: " ++ fpToText bundleDest- createBundleV2 CreateBundleV2- { cb2Plan = plan- , cb2Type = snapshotType- , cb2DocsDir = pbDocDir pb- , cb2Dest = bundleDest- }-- when (bfDoUpload buildFlags) $- finallyUpload (bfUploadV2 buildFlags) settings man--justUploadNightly- :: Text -- ^ nightly date- -> IO ()-justUploadNightly day = do- plan <- decodeFileEither (fpToString $ nightlyPlanFile day)- >>= either throwM return- withManager tlsManagerSettings $ finallyUpload False $ nightlySettings day plan--getStackageAuthToken :: IO Text-getStackageAuthToken = do- mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN"- case mtoken of- Nothing -> decodeUtf8 <$> readFile "/auth-token"- Just token -> return $ pack token---- | The final part of the complete build process: uploading a bundle,--- docs and a distro to hackage.-finallyUpload :: Bool -- ^ use v2 upload- -> Settings -> Manager -> IO ()-finallyUpload useV2 settings@Settings{..} man = do- putStrLn "Uploading bundle to Stackage Server"-- token <- getStackageAuthToken-- if useV2- then do- res <- flip uploadBundleV2 man UploadBundleV2- { ub2Server = def- , ub2AuthToken = token- , ub2Bundle = bundleDest- }- putStrLn $ "New snapshot available at: " ++ res- else do- now <- epochTime- let ghcVer = display $ siGhcVersion $ bpSystemInfo plan- (ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def- { ubContents = serverBundle now (title ghcVer) slug plan- , ubAuthToken = token- }- putStrLn $ "New ident: " ++ unSnapshotIdent ident- forM_ mloc $ \loc ->- putStrLn $ "Track progress at: " ++ loc-- putStrLn "Uploading docs to Stackage Server"- res1 <- tryAny $ uploadDocs UploadDocs- { udServer = def- , udAuthToken = token- , udDocs = pbDocDir pb- , udSnapshot = ident- } man- putStrLn $ "Doc upload response: " ++ tshow res1-- putStrLn "Uploading doc map"- tryAny (uploadDocMap UploadDocMap- { udmServer = def- , udmAuthToken = token- , udmSnapshot = ident- , udmDocDir = pbDocDir pb- , udmPlan = plan- } man) >>= print-- postBuild `catchAny` print-- ecreds <- tryIO $ readFile "/hackage-creds"- case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of- [username, password] -> do- putStrLn "Uploading as Hackage distro"- res2 <- uploadHackageDistroNamed distroName plan username password man- putStrLn $ "Distro upload response: " ++ tshow res2- _ -> putStrLn "No creds found, skipping Hackage distro upload"- where- pb = getPerformBuild (error "finallyUpload.buildFlags") settings
− Stackage/CorePackages.hs
@@ -1,53 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-module Stackage.CorePackages- ( getCorePackages- , getCoreExecutables- , getGhcVersion- ) where--import qualified Data.Text as T-import Filesystem (listDirectory)-import Stackage.Prelude-import System.Directory (findExecutable)---- | Get a @Map@ of all of the core packages. Core packages are defined as--- packages which ship with GHC itself.------ Precondition: GHC global package database has only core packages, and GHC--- ships with just a single version of each packages.-getCorePackages :: IO (Map PackageName Version)-getCorePackages =- withCheckedProcess cp $ \ClosedStream src Inherited ->- src $$ decodeUtf8C =$ linesUnboundedC =$ foldMapMC parsePackage- where- cp = proc "ghc-pkg" ["--no-user-package-conf", "list"]- parsePackage t- | ":" `isInfixOf` t = return mempty- | Just p <- stripSuffix "-" p' = singletonMap- <$> simpleParse p- <*> simpleParse v- | otherwise = return mempty- where- (p', v) = T.breakOnEnd "-" $ dropParens $ T.strip t-- dropParens s- | length s > 2 && headEx s == '(' && lastEx s == ')' =- initEx $ tailEx s- | otherwise = s---- | A list of executables that are shipped with GHC.-getCoreExecutables :: IO (Set ExeName)-getCoreExecutables = do- mfp <- findExecutable "ghc"- dir <-- case mfp of- Nothing -> error "No ghc executable found on PATH"- Just fp -> return $ directory $ fpFromString fp- (setFromList . map (ExeName . fpToText . filename)) <$> listDirectory dir--getGhcVersion :: IO Version-getGhcVersion = do- withCheckedProcess (proc "ghc" ["--numeric-version"]) $- \ClosedStream src Inherited ->- (src $$ decodeUtf8C =$ foldC) >>= simpleParse
+ Stackage/Dummy.hs view
@@ -0,0 +1,3 @@+-- | This module does absolutely nothing. It's present so that cabal can more+-- easily track whether the stackage package is installed.+module Stackage.Dummy () where
− Stackage/GhcPkg.hs
@@ -1,104 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}--- | General commands related to ghc-pkg.--module Stackage.GhcPkg- ( setupPackageDatabase- ) where--import Data.Conduit-import qualified Data.Conduit.List as CL-import Data.Conduit.Process-import qualified Data.Conduit.Text as CT-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import Distribution.Compat.ReadP-import Distribution.Package-import Distribution.Text (parse)-import Filesystem.Path.CurrentOS (FilePath)-import qualified Filesystem.Path.CurrentOS as FP-import Data.Map (Map)-import Data.Version (Version)-import Stackage.Prelude-import Filesystem (removeTree)--setupPackageDatabase- :: Maybe FilePath -- ^ database location, Nothing if using global DB- -> FilePath -- ^ documentation root- -> (ByteString -> IO ()) -- ^ logging- -> Map PackageName Version -- ^ packages and versions to be installed- -> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package- -> IO (Set PackageName) -- ^ packages remaining in the database after cleanup-setupPackageDatabase mdb docDir log' toInstall onUnregister = do- registered1 <- getRegisteredPackages flags- forM_ registered1 $ \pi@(PackageIdentifier name version) ->- case lookup name toInstall of- Just version' | version /= version' -> unregisterPackage log' onUnregister docDir flags pi- _ -> return ()- broken <- getBrokenPackages flags- forM_ broken $ unregisterPackage log' onUnregister docDir flags- foldMap (\(PackageIdentifier name _) -> singletonSet name)- <$> getRegisteredPackages flags- where- flags = ghcPkgFlags mdb--ghcPkgFlags :: Maybe FilePath -> [String]-ghcPkgFlags mdb =- "--no-user-package-db" :- case mdb of- Nothing -> ["--global"]- Just fp -> ["--package-db=" ++ fpToString fp]---- | Get broken packages.-getBrokenPackages :: [String] -> IO [PackageIdentifier]-getBrokenPackages flags = do- (_,ps) <- sourceProcessWithConsumer- (proc- "ghc-pkg"- ("check" : "--simple-output" : flags))- (CT.decodeUtf8 $= CT.lines $= CL.consume)- return (mapMaybe parsePackageIdent (T.words (T.unlines ps)))---- | Get available packages.-getRegisteredPackages :: [String] -> IO [PackageIdentifier]-getRegisteredPackages flags = do- (_,ps) <- sourceProcessWithConsumer- (proc- "ghc-pkg"- ("list" : "--simple-output" : flags))- (CT.decodeUtf8 $= CT.lines $= CL.consume)- return (mapMaybe parsePackageIdent (T.words (T.unlines ps)))---- | Parse a package identifier: foo-1.2.3-parsePackageIdent :: Text -> Maybe PackageIdentifier-parsePackageIdent = fmap fst .- listToMaybe .- filter (null . snd) .- readP_to_S parse . T.unpack---- | Unregister a package.-unregisterPackage :: (ByteString -> IO ()) -- ^ log func- -> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package- -> FilePath -- ^ doc directory- -> [String] -> PackageIdentifier -> IO ()-unregisterPackage log' onUnregister docDir flags ident@(PackageIdentifier name _) = do- log' $ "Unregistering " ++ encodeUtf8 (display ident) ++ "\n"- onUnregister ident-- -- Delete libraries- sourceProcessWithConsumer- (proc "ghc-pkg" ("describe" : flags ++ [unpack $ display ident]))- (CT.decodeUtf8- $= CT.lines- $= CL.mapMaybe parseLibraryDir- $= CL.mapM_ (void . tryIO . removeTree))-- void (readProcessWithExitCode- "ghc-pkg"- ("unregister": flags ++ ["--force", unpack $ display name])- "")-- void $ tryIO $ removeTree $ docDir </> fpFromText (display ident)- where- parseLibraryDir = fmap fpFromText . stripPrefix "library-dirs: "
− Stackage/GithubPings.hs
@@ -1,36 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-}-module Stackage.GithubPings- ( getGithubPings- ) where--import Distribution.PackageDescription-import Stackage.BuildConstraints-import Stackage.Prelude---- | Determine accounts to be pinged on Github based on various metadata in the--- package description.-getGithubPings :: BuildConstraints -- ^ for mapping to pingees- -> GenericPackageDescription -> Set Text-getGithubPings bc gpd =- foldMap (\(pack -> name) -> fromMaybe (singletonSet name) (lookup name (bcGithubUsers bc))) $- goHomepage (homepage $ packageDescription gpd) ++- concatMap goRepo (sourceRepos $ packageDescription gpd)- where- goHomepage t = do- prefix <-- [ "http://github.com/"- , "https://github.com/"- , "git://github.com/"- , "git@github.com:"- ]- t' <- maybeToList $ stripPrefix prefix t- let t'' = takeWhile (/= '/') t'- guard $ not $ null t''- return t''-- goRepo sr =- case (repoType sr, repoLocation sr) of- (Just Git, Just s) -> goHomepage s- _ -> []
− Stackage/InstallBuild.hs
@@ -1,100 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Stackage.InstallBuild- ( InstallFlags (..)- , BuildPlanSource (..)- , installBuild- ) where--import qualified Codec.Archive.Tar as Tar-import qualified Codec.Compression.GZip as GZip-import qualified Data.Yaml as Yaml-import Network.HTTP.Client-import Network.HTTP.Client.TLS (tlsManagerSettings)-import Stackage.BuildPlan-import Stackage.CheckBuildPlan-import Stackage.PerformBuild-import Stackage.Prelude-import System.IO (BufferMode (LineBuffering), hSetBuffering)---- | Flags passed in from the command line.-data InstallFlags = InstallFlags- { ifPlanSource :: !BuildPlanSource- , ifInstallDest :: !FilePath- , ifLogDir :: !(Maybe FilePath)- , ifJobs :: !Int- , ifGlobalInstall :: !Bool- , ifEnableTests :: !Bool- , ifEnableHaddock :: !Bool- , ifEnableLibProfiling :: !Bool- , ifEnableExecDyn :: !Bool- , ifVerbose :: !Bool- , ifSkipCheck :: !Bool- } deriving (Show)---- | Source for build plan.-data BuildPlanSource = BPSBundleWeb String- | BPSFile FilePath- deriving (Show)--getPerformBuild :: BuildPlan -> InstallFlags -> PerformBuild-getPerformBuild plan InstallFlags{..} =- PerformBuild- { pbPlan = plan- , pbInstallDest = ifInstallDest- , pbLogDir = fromMaybe (ifInstallDest </> "logs") ifLogDir- , pbLog = hPut stdout- , pbJobs = ifJobs- , pbGlobalInstall = ifGlobalInstall- , pbEnableTests = ifEnableTests- , pbEnableHaddock = ifEnableHaddock- , pbEnableLibProfiling = ifEnableLibProfiling- , pbEnableExecDyn = ifEnableExecDyn- , pbVerbose = ifVerbose- , pbAllowNewer = ifSkipCheck- }---- | Install stackage from an existing build plan.-installBuild :: InstallFlags -> IO ()-installBuild installFlags@InstallFlags{..} = do- hSetBuffering stdout LineBuffering-- putStrLn $ "Loading build plan"- plan <- case ifPlanSource of- BPSBundleWeb url -> withManager tlsManagerSettings $ \man -> do- req <- parseUrl url- res <- httpLbs req man- planBSL <- getPlanEntry $ Tar.read $ GZip.decompress (responseBody res)- decodeBuildPlan planBSL- BPSFile path -> Yaml.decodeFileEither (fpToString path) >>= either throwM return-- if ifSkipCheck- then putStrLn "Skipping build plan check"- else do- putStrLn "Checking build plan"- checkBuildPlan plan-- putStrLn "Performing build"- performBuild (getPerformBuild plan installFlags) >>= mapM_ putStrLn-- where- getPlanEntry Tar.Done = throwIO NoBuildPlanException- getPlanEntry (Tar.Fail e) = throwIO e- getPlanEntry (Tar.Next entry entries)- | Tar.entryPath entry == "build-plan.yaml" =- case Tar.entryContent entry of- Tar.NormalFile bs _ -> return bs- _ -> throwIO NoBuildPlanException- | otherwise = getPlanEntry entries-- decodeBuildPlan =- either throwIO return . Yaml.decodeEither' . toStrict--data InstallBuildException = NoBuildPlanException- deriving (Typeable)-instance Exception InstallBuildException-instance Show InstallBuildException where- show NoBuildPlanException = "Bundle has missing or invalid build-plan.yaml"
− Stackage/PackageDescription.hs
@@ -1,200 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}--- | Manipulate @GenericPackageDescription@ from Cabal into something more--- useful for us.-module Stackage.PackageDescription- ( SimpleDesc (..)- , toSimpleDesc- , CheckCond (..)- , Component (..)- , DepInfo (..)- ) where--import Control.Monad.Writer.Strict (MonadWriter, execWriterT,- tell)-import Data.Aeson-import qualified Data.Map as Map-import Distribution.Compiler (CompilerFlavor)-import Distribution.Package (Dependency (..))-import Distribution.PackageDescription-import Distribution.System (Arch, OS)-import Stackage.Prelude--data Component = CompLibrary- | CompExecutable- | CompTestSuite- | CompBenchmark- deriving (Show, Read, Eq, Ord, Enum, Bounded)--compToText :: Component -> Text-compToText CompLibrary = "library"-compToText CompExecutable = "executable"-compToText CompTestSuite = "test-suite"-compToText CompBenchmark = "benchmark"--instance ToJSON Component where- toJSON = toJSON . compToText-instance FromJSON Component where- parseJSON = withText "Component" $ \t -> maybe- (fail $ "Invalid component: " ++ unpack t)- return- (lookup t comps)- where- comps = asHashMap $ mapFromList $ map (compToText &&& id) [minBound..maxBound]--data DepInfo = DepInfo- { diComponents :: Set Component- , diRange :: VersionRange- }- deriving (Show, Eq)--instance Semigroup DepInfo where- DepInfo a x <> DepInfo b y = DepInfo- (a <> b)- (intersectVersionRanges x y)-instance ToJSON DepInfo where- toJSON DepInfo {..} = object- [ "components" .= diComponents- , "range" .= display diRange- ]-instance FromJSON DepInfo where- parseJSON = withObject "DepInfo" $ \o -> do- diComponents <- o .: "components"- diRange <- o .: "range" >>= either (fail . show) return . simpleParse- return DepInfo {..}---- | A simplified package description that tracks:------ * Package dependencies------ * Build tool dependencies------ * Provided executables------ It has fully resolved all conditionals-data SimpleDesc = SimpleDesc- { sdPackages :: Map PackageName DepInfo- , sdTools :: Map ExeName DepInfo- , sdProvidedExes :: Set ExeName- , sdModules :: Set Text- -- ^ modules exported by the library- }- deriving (Show, Eq)-instance Monoid SimpleDesc where- mempty = SimpleDesc mempty mempty mempty mempty- mappend (SimpleDesc a b c d) (SimpleDesc w x y z) = SimpleDesc- (unionWith (<>) a w)- (unionWith (<>) b x)- (c ++ y)- (d ++ z)-instance ToJSON SimpleDesc where- toJSON SimpleDesc {..} = object- [ "packages" .= Map.mapKeysWith const unPackageName sdPackages- , "tools" .= Map.mapKeysWith const unExeName sdTools- , "provided-exes" .= sdProvidedExes- , "modules" .= sdModules- ]-instance FromJSON SimpleDesc where- parseJSON = withObject "SimpleDesc" $ \o -> do- sdPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages")- sdTools <- Map.mapKeysWith const ExeName <$> (o .: "tools")- sdProvidedExes <- o .: "provided-exes"- sdModules <- o .: "modules"- return SimpleDesc {..}---- | Convert a 'GenericPackageDescription' into a 'SimpleDesc' by following the--- constraints in the provided 'CheckCond'.-toSimpleDesc :: MonadThrow m- => CheckCond- -> GenericPackageDescription- -> m SimpleDesc-toSimpleDesc cc gpd = execWriterT $ do- forM_ (condLibrary gpd) $ tellTree cc CompLibrary libBuildInfo getModules- forM_ (condExecutables gpd) $ tellTree cc CompExecutable buildInfo noModules . snd- tell mempty { sdProvidedExes = setFromList- $ map (fromString . fst)- $ condExecutables gpd- }- when (ccIncludeTests cc) $ forM_ (condTestSuites gpd)- $ tellTree cc CompTestSuite testBuildInfo noModules . snd- when (ccIncludeBenchmarks cc) $ forM_ (condBenchmarks gpd)- $ tellTree cc CompBenchmark benchmarkBuildInfo noModules . snd- where- noModules = const mempty- getModules = setFromList . map display . exposedModules---- | Convert a single CondTree to a 'SimpleDesc'.-tellTree :: (MonadWriter SimpleDesc m, MonadThrow m)- => CheckCond- -> Component- -> (a -> BuildInfo)- -> (a -> Set Text) -- ^ get module names- -> CondTree ConfVar [Dependency] a- -> m ()-tellTree cc component getBI getModules =- loop- where- loop (CondNode dat deps comps) = do- tell mempty- { sdPackages = unionsWith (<>) $ flip map deps- $ \(Dependency x y) -> singletonMap x DepInfo- { diComponents = singletonSet component- , diRange = simplifyVersionRange y- }- , sdTools = unionsWith (<>) $ flip map (buildTools $ getBI dat)- $ \(Dependency name range) -> singletonMap- -- In practice, cabal files refer to the exe name, not the- -- package name.- (ExeName $ unPackageName name)- DepInfo- { diComponents = singletonSet component- , diRange = simplifyVersionRange range- }- , sdModules = getModules dat- }- forM_ comps $ \(cond, ontrue, onfalse) -> do- b <- checkCond cc cond- if b- then loop ontrue- else maybe (return ()) loop onfalse---- | Resolve a condition to a boolean based on the provided 'CheckCond'.-checkCond :: MonadThrow m => CheckCond -> Condition ConfVar -> m Bool-checkCond CheckCond {..} cond0 =- go cond0- where- go (Var (OS os)) = return $ os == ccOS- go (Var (Arch arch)) = return $ arch == ccArch- go (Var (Flag flag)) =- case lookup flag ccFlags of- Nothing -> throwM $ FlagNotDefined ccPackageName flag cond0- Just b -> return b- go (Var (Impl flavor range)) = return- $ flavor == ccCompilerFlavor- && ccCompilerVersion `withinRange` range- go (Lit b) = return b- go (CNot c) = not `liftM` go c- go (CAnd x y) = (&&) `liftM` go x `ap` go y- go (COr x y) = (||) `liftM` go x `ap` go y--data CheckCondException = FlagNotDefined PackageName FlagName (Condition ConfVar)- deriving (Show, Typeable)-instance Exception CheckCondException--data CheckCond = CheckCond- { ccPackageName :: PackageName -- for debugging only- , ccOS :: OS- , ccArch :: Arch- , ccFlags :: Map FlagName Bool- , ccCompilerFlavor :: CompilerFlavor- , ccCompilerVersion :: Version- , ccIncludeTests :: Bool- , ccIncludeBenchmarks :: Bool- }
− Stackage/PackageIndex.hs
@@ -1,127 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ViewPatterns #-}--- | Dealing with the 00-index file and all its cabal files.-module Stackage.PackageIndex- ( sourcePackageIndex- , UnparsedCabalFile (..)- , getLatestDescriptions- ) where--import qualified Codec.Archive.Tar as Tar-import Data.Conduit.Lazy (MonadActive,- lazyConsume)-import qualified Data.Text as T-import Distribution.PackageDescription (package,- packageDescription)-import Distribution.PackageDescription.Parse (ParseResult (..),- parsePackageDescription)-import Distribution.ParseUtils (PError)-import Stackage.Prelude-import System.Directory (getAppUserDataDirectory)---- | Name of the 00-index.tar downloaded from Hackage.-getPackageIndexPath :: MonadIO m => m FilePath-getPackageIndexPath = liftIO $ do- c <- getCabalRoot- configLines <- runResourceT $ sourceFile (c </> "config")- $$ decodeUtf8C- =$ linesUnboundedC- =$ concatMapC getRemoteCache- =$ sinkList- case configLines of- [x] -> return $ x </> "hackage.haskell.org" </> "00-index.tar"- [] -> error $ "No remote-repo-cache found in Cabal config file"- _ -> error $ "Multiple remote-repo-cache entries found in Cabal config file"- where- getCabalRoot :: IO FilePath- getCabalRoot = fpFromString <$> getAppUserDataDirectory "cabal"-- getRemoteCache s = do- ("remote-repo-cache", stripPrefix ":" -> Just v) <- Just $ break (== ':') s- Just $ fpFromText $ T.strip v---- | A cabal file with name and version parsed from the filepath, and the--- package description itself ready to be parsed. It's left in unparsed form--- for efficiency.-data UnparsedCabalFile = UnparsedCabalFile- { ucfName :: PackageName- , ucfVersion :: Version- , ucfParse :: forall m. MonadThrow m => m GenericPackageDescription- }---- | Stream all of the cabal files from the 00-index tar file.-sourcePackageIndex :: (MonadThrow m, MonadResource m, MonadActive m, MonadBaseControl IO m)- => Producer m UnparsedCabalFile-sourcePackageIndex = do- fp <- getPackageIndexPath- -- yay for the tar package. Use lazyConsume instead of readFile to get some- -- kind of resource protection- lbs <- lift $ fromChunks <$> lazyConsume (sourceFile fp)- loop (Tar.read lbs)- where- loop (Tar.Next e es) = goE e >> loop es- loop Tar.Done = return ()- loop (Tar.Fail e) = throwM e-- goE e- | Just front <- stripSuffix ".cabal" $ pack $ Tar.entryPath e- , Tar.NormalFile lbs _size <- Tar.entryContent e = do- (name, version) <- parseNameVersion front- yield UnparsedCabalFile- { ucfName = name- , ucfVersion = version- , ucfParse = goContent (Tar.entryPath e) name version lbs- }- | otherwise = return ()-- goContent fp name version lbs =- case parsePackageDescription $ unpack $ decodeUtf8 lbs of- ParseFailed e -> throwM $ CabalParseException (fpFromString fp) e- ParseOk _warnings gpd -> do- let pd = packageDescription gpd- PackageIdentifier name' version' = package pd- when (name /= name' || version /= version') $- throwM $ MismatchedNameVersion (fpFromString fp)- name name' version version'- return gpd-- parseNameVersion t1 = do- let (p', t2) = break (== '/') $ T.replace "\\" "/" t1- p <- simpleParse p'- t3 <- maybe (throwM $ InvalidCabalPath t1 "no slash") return- $ stripPrefix "/" t2- let (v', t4) = break (== '/') t3- v <- simpleParse v'- when (t4 /= cons '/' p') $ throwM $ InvalidCabalPath t1 $ "Expected at end: " ++ p'- return (p, v)--data InvalidCabalPath = InvalidCabalPath Text Text- deriving (Show, Typeable)-instance Exception InvalidCabalPath--data CabalParseException = CabalParseException FilePath PError- | MismatchedNameVersion FilePath PackageName PackageName Version Version- deriving (Show, Typeable)-instance Exception CabalParseException---- | Get all of the latest descriptions for name/version pairs matching the--- given criterion.-getLatestDescriptions :: MonadIO m- => (PackageName -> Version -> Bool)- -> (GenericPackageDescription -> IO desc)- -> m (Map PackageName desc)-getLatestDescriptions f parseDesc = liftIO $ do- m <- runResourceT $ sourcePackageIndex $$ filterC f' =$ foldlC add mempty- forM m $ \ucf -> liftIO $ ucfParse ucf >>= parseDesc- where- f' ucf = f (ucfName ucf) (ucfVersion ucf)- add m ucf =- case lookup name m of- Just ucf' | ucfVersion ucf < ucfVersion ucf' -> m- _ -> insertMap name ucf m- where- name = ucfName ucf
− Stackage/PerformBuild.hs
@@ -1,555 +0,0 @@--- | Perform an actual build, generate a binary package database and a--- documentation directory in the process.-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-module Stackage.PerformBuild- ( performBuild- , PerformBuild (..)- , BuildException (..)- , pbDocDir- ) where--import Control.Concurrent.Async (async)-import Control.Concurrent.STM.TSem-import Control.Monad.Writer.Strict (execWriter, tell)-import qualified Data.Map as Map-import Data.NonNull (fromNullable)-import Filesystem (canonicalizePath, createTree,- getWorkingDirectory, isDirectory,- removeTree, rename, isFile, removeFile)-import Filesystem.Path (parent)-import qualified Filesystem.Path as F-import Stackage.BuildConstraints-import Stackage.BuildPlan-import Stackage.GhcPkg-import Stackage.PackageDescription-import Stackage.Prelude hiding (pi)-import System.Directory (findExecutable)-import System.Environment (getEnvironment)-import System.IO (IOMode (WriteMode),- openBinaryFile)-import System.IO.Temp (withSystemTempDirectory)--data BuildException = BuildException (Map PackageName BuildFailure) [Text]- deriving Typeable-instance Exception BuildException-instance Show BuildException where- show (BuildException m warnings) =- unlines $ map go (mapToList m) ++ map unpack warnings- where- go (PackageName name, bf) = concat- [ name- , ": "- , show bf- ]--data BuildFailure = DependencyFailed PackageName- | DependencyMissing PackageName- | ToolMissing ExeName- | NotImplemented- | BuildFailureException SomeException- deriving (Show, Typeable)-instance Exception BuildFailure--data PerformBuild = PerformBuild- { pbPlan :: BuildPlan- , pbInstallDest :: FilePath- , pbLog :: ByteString -> IO ()- , pbLogDir :: FilePath- , pbJobs :: Int- , pbGlobalInstall :: Bool- -- ^ Register packages in the global database- , pbEnableTests :: Bool- , pbEnableHaddock :: Bool- , pbEnableLibProfiling :: Bool- , pbEnableExecDyn :: Bool- , pbVerbose :: Bool- , pbAllowNewer :: Bool- -- ^ Pass --allow-newer to cabal configure- }--data PackageInfo = PackageInfo- { piPlan :: PackagePlan- , piName :: PackageName- , piResult :: TMVar Bool- }--waitForDeps :: Map ExeName (Set PackageName)- -> Map PackageName PackageInfo- -> Set Component- -> BuildPlan- -> PackageInfo- -> IO a- -> IO a-waitForDeps toolMap packageMap activeComps bp pi action = do- atomically $ do- mapM_ checkPackage $ Map.keys $ filterUnused $ sdPackages $ ppDesc $ piPlan pi- forM_ (Map.keys $ filterUnused $ sdTools $ ppDesc $ piPlan pi) $ \exe -> do- case lookup exe toolMap >>= fromNullable . map checkPackage . setToList of- Nothing- | isCoreExe exe -> return ()- -- https://github.com/jgm/zip-archive/issues/23- -- - | otherwise -> throwSTM $ ToolMissing exe- | otherwise -> return ()- Just packages -> ofoldl1' (<|>) packages- action- where- filterUnused :: Ord key => Map key DepInfo -> Map key DepInfo- filterUnused =- mapFromList . filter (go . snd) . mapToList- where- go = not . null . intersection activeComps . diComponents-- checkPackage package | package == piName pi = return ()- checkPackage package =- case lookup package packageMap of- Nothing- | isCore package -> return ()- | otherwise -> throwSTM $ DependencyMissing package- Just dep -> do- res <- readTMVar $ piResult dep- unless res $ throwSTM $ DependencyFailed package-- isCore = (`member` siCorePackages (bpSystemInfo bp))- isCoreExe = (`member` siCoreExecutables (bpSystemInfo bp))--withCounter :: TVar Int -> IO a -> IO a-withCounter counter = bracket_- (atomically $ modifyTVar counter (+ 1))- (atomically $ modifyTVar counter (subtract 1))--withTSem :: TSem -> IO a -> IO a-withTSem sem = bracket_ (atomically $ waitTSem sem) (atomically $ signalTSem sem)---- | Returns @Nothing@ if installing to a global database-pbDatabase :: PerformBuild -> Maybe FilePath-pbDatabase pb- | pbGlobalInstall pb = Nothing- | otherwise = Just $ pbInstallDest pb </> "pkgdb"--pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath-pbBinDir pb = pbInstallDest pb </> "bin"-pbLibDir pb = pbInstallDest pb </> "lib"-pbDataDir pb = pbInstallDest pb </> "share"-pbDocDir pb = pbInstallDest pb </> "doc"---- | Directory keeping previous result info-pbPrevResDir :: PerformBuild -> FilePath-pbPrevResDir pb = pbInstallDest pb </> "prevres"--performBuild :: PerformBuild -> IO [Text]-performBuild pb = do- cwd <- getWorkingDirectory- performBuild' pb- { pbInstallDest = cwd </> pbInstallDest pb- , pbLogDir = cwd </> pbLogDir pb- }--performBuild' :: PerformBuild -> IO [Text]-performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do- -- First make sure to fetch all of the dependencies... just in case Hackage- -- has an outage. Don't feel like wasting hours of CPU time.- pbLog $ encodeUtf8 "Pre-fetching all packages\n"- let toDownload = flip map (mapToList $ bpPackages pbPlan)- $ \(name, plan) -> unpack $ concat- [ display name- , "-"- , display $ ppVersion plan- ]- withCheckedProcess- (proc "cabal"- $ "fetch"- : "--no-dependencies"- : toDownload)- $ \ClosedStream Inherited Inherited -> return ()-- let removeTree' fp = whenM (isDirectory fp) (removeTree fp)- removeTree' pbLogDir-- forM_ (pbDatabase pb) $ \db ->- unlessM (isFile $ db </> "package.cache") $ do- createTree $ parent db- withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])- $ \ClosedStream Inherited Inherited -> return ()- pbLog $ encodeUtf8 "Copying built-in Haddocks\n"- copyBuiltInHaddocks (pbDocDir pb)-- sem <- atomically $ newTSem pbJobs- active <- newTVarIO (0 :: Int)- let toolMap = makeToolMap $ bpPackages pbPlan- packageMap <- fmap fold $ forM (mapToList $ bpPackages pbPlan)- $ \(name, plan) -> do- let piPlan = plan- piName = name- piResult <- newEmptyTMVarIO- return $ singletonMap name PackageInfo {..}-- errsVar <- newTVarIO mempty- warningsVar <- newTVarIO id- mutex <- newMVar ()- env <- getEnvironment- haddockFiles <- newTVarIO mempty-- registeredPackages <- setupPackageDatabase- (pbDatabase pb)- (pbDocDir pb)- pbLog- (ppVersion <$> bpPackages pbPlan)- (deletePreviousResults pb)-- forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages- SingleBuild- { sbSem = sem- , sbErrsVar = errsVar- , sbWarningsVar = warningsVar- , sbActive = active- , sbToolMap = toolMap- , sbPackageMap = packageMap- , sbBuildDir = builddir- , sbPackageInfo = pi- , sbRegisterMutex = mutex- , sbModifiedEnv = maybe- id- (\db -> (("HASKELL_PACKAGE_SANDBOX", fpToString db):))- (pbDatabase pb)- (filter allowedEnv $ map fixEnv env)- , sbHaddockFiles = haddockFiles- }-- void $ tryAny $ atomically $ readTVar active >>= checkSTM . (== 0)-- warnings <- ($ []) <$> readTVarIO warningsVar- errs <- readTVarIO errsVar- when (not $ null errs) $ throwM $ BuildException errs warnings- return warnings- where- withBuildDir f = withSystemTempDirectory "stackage-build" (f . fpFromString)-- fixEnv (p, x)- -- Thank you Windows having case-insensitive environment variables...- | toUpper p == "PATH" = (p, fpToString (pbBinDir pb) ++ pathSep : x)- | otherwise = (p, x)-- allowedEnv (k, _) = k `notMember` bannedEnvs-- -- | Separate for the PATH environment variable- pathSep :: Char-#ifdef mingw32_HOST_OS- pathSep = ';'-#else- pathSep = ':'-#endif---- | Environment variables we don't allow to be passed on to child processes.-bannedEnvs :: Set String-bannedEnvs = setFromList- [ "STACKAGE_AUTH_TOKEN"- ]--data SingleBuild = SingleBuild- { sbSem :: TSem- , sbErrsVar :: TVar (Map PackageName BuildFailure)- , sbWarningsVar :: TVar ([Text] -> [Text])- , sbActive :: TVar Int- , sbToolMap :: Map ExeName (Set PackageName)- , sbPackageMap :: Map PackageName PackageInfo- , sbBuildDir :: FilePath- , sbPackageInfo :: PackageInfo- , sbRegisterMutex :: MVar ()- , sbModifiedEnv :: [(String, String)]- , sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file- }--singleBuild :: PerformBuild- -> Set PackageName -- ^ registered packages- -> SingleBuild -> IO ()-singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =- withCounter sbActive- $ handle updateErrs- $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))- $ inner- where- libComps = setFromList [CompLibrary, CompExecutable]- testComps = insertSet CompTestSuite libComps- inner = do- let wfd comps =- waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo- . withTSem sbSem- withUnpacked <- wfd libComps buildLibrary-- wfd testComps (runTests withUnpacked)-- pname = piName sbPackageInfo- pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo)- name = display pname- namever = concat- [ name- , "-"- , display $ ppVersion $ piPlan sbPackageInfo- ]-- runIn wdir getOutH cmd args = do- outH <- getOutH- withCheckedProcess (cp outH) $ \ClosedStream UseProvidedHandle UseProvidedHandle ->- (return () :: IO ())- where- cp outH = (proc (unpack $ asText cmd) (map (unpack . asText) args))- { cwd = Just $ fpToString wdir- , std_out = UseHandle outH- , std_err = UseHandle outH- , env = Just sbModifiedEnv- }- runParent = runIn sbBuildDir- runChild = runIn childDir- childDir = sbBuildDir </> fpFromText namever-- log' t = do- i <- readTVarIO sbActive- errs <- readTVarIO sbErrsVar- pbLog $ encodeUtf8 $ concat- [ t- , " (pending: "- , tshow i- , ", failures: "- , tshow $ length errs- , ")\n"- ]- libOut = pbLogDir </> fpFromText namever </> "build.out"- testOut = pbLogDir </> fpFromText namever </> "test.out"- testRunOut = pbLogDir </> fpFromText namever </> "test-run.out"-- wf fp inner' = do- ref <- newIORef Nothing- let cleanup = do- mh <- readIORef ref- forM_ mh hClose- getH = do- mh <- readIORef ref- case mh of- Just h -> return h- Nothing -> mask_ $ do- createTree $ parent fp- h <- openBinaryFile (fpToString fp) WriteMode- writeIORef ref $ Just h- return h-- inner' getH `finally` cleanup-- configArgs = ($ []) $ execWriter $ do- when pbAllowNewer $ tell' "--allow-newer"- tell' "--package-db=clear"- tell' "--package-db=global"- forM_ (pbDatabase pb) $ \db -> tell' $ "--package-db=" ++ fpToText db- tell' $ "--libdir=" ++ fpToText (pbLibDir pb)- tell' $ "--bindir=" ++ fpToText (pbBinDir pb)- tell' $ "--datadir=" ++ fpToText (pbDataDir pb)- tell' $ "--docdir=" ++ fpToText (pbDocDir pb)- tell' $ "--flags=" ++ flags- when (pbEnableLibProfiling && pcEnableLibProfile) $- tell' "--enable-library-profiling"- when pbEnableExecDyn $ tell' "--enable-executable-dynamic"- where- tell' x = tell (x:)-- flags :: Text- flags = unwords $ map go $ mapToList pcFlagOverrides- where- go (name', isOn) = concat- [ if isOn then "" else "-"- , unFlagName name'- ]-- PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo-- buildLibrary = wf libOut $ \getOutH -> do- let run a b = do when pbVerbose $ log' (unwords (a : b))- runChild getOutH a b-- isUnpacked <- newIORef False- let withUnpacked inner = do- unlessM (readIORef isUnpacked) $ do- log' $ "Unpacking " ++ namever- runParent getOutH "cabal" ["unpack", namever]- writeIORef isUnpacked True- inner-- isConfiged <- newIORef False- let withConfiged inner = withUnpacked $ do- unlessM (readIORef isConfiged) $ do- log' $ "Configuring " ++ namever- run "cabal" $ "configure" : configArgs- writeIORef isConfiged True- inner-- prevBuildResult <- getPreviousResult pb Build pident- unless (prevBuildResult == PRSuccess) $ withConfiged $ do- assert (pname `notMember` registeredPackages) $ do- deletePreviousResults pb pident-- log' $ "Building " ++ namever- run "cabal" ["build"]-- log' $ "Copying/registering " ++ namever- run "cabal" ["copy"]- withMVar sbRegisterMutex $ const $- run "cabal" ["register"]-- savePreviousResult pb Build pident True-- -- Even if the tests later fail, we can allow other libraries to build- -- on top of our successful results- --- -- FIXME do we need to wait to do this until after Haddocks build?- -- otherwise, we could have a race condition and try to build a- -- dependency's haddocks before this finishes- atomically $ putTMVar (piResult sbPackageInfo) True-- prevHaddockResult <- getPreviousResult pb Haddock pident- let needHaddock = pbEnableHaddock- && checkPrevResult prevHaddockResult pcHaddocks- && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)- when needHaddock $ withConfiged $ do- log' $ "Haddocks " ++ namever- hfs <- readTVarIO sbHaddockFiles- let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat- [ "--haddock-options=--read-interface="- , "../"- , pkgVer- , "/,"- , fpToText hf- ]- args = "haddock"- : "--hyperlink-source"- : "--html"- : "--hoogle"- : "--html-location=../$pkg-$version/"- : hfsOpts-- eres <- tryAny $ run "cabal" args-- forM_ eres $ \() -> do- renameOrCopy- (childDir </> "dist" </> "doc" </> "html" </> fpFromText name)- (pbDocDir pb </> fpFromText namever)-- enewPath <- tryIO- $ canonicalizePath- $ pbDocDir pb- </> fpFromText namever- </> fpFromText name <.> "haddock"- case enewPath of- Left e -> warn $ tshow e- Right newPath -> atomically- $ modifyTVar sbHaddockFiles- $ insertMap namever newPath-- savePreviousResult pb Haddock pident $ either (const False) (const True) eres- case (eres, pcHaddocks) of- (Left e, ExpectSuccess) -> throwM e- (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"- _ -> return ()-- return withUnpacked-- runTests withUnpacked = wf testOut $ \getOutH -> do- let run = runChild getOutH-- prevTestResult <- getPreviousResult pb Test pident- let needTest = pbEnableTests- && checkPrevResult prevTestResult pcTests- when needTest $ withUnpacked $ do- log' $ "Test configure " ++ namever- run "cabal" $ "configure" : "--enable-tests" : configArgs-- eres <- tryAny $ do- log' $ "Test build " ++ namever- run "cabal" ["build"]-- log' $ "Test run " ++ namever- run "cabal" ["test", "--log=" ++ fpToText testRunOut]-- savePreviousResult pb Test pident $ either (const False) (const True) eres- case (eres, pcTests) of- (Left e, ExpectSuccess) -> throwM e- (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"- _ -> return ()-- warn t = atomically $ modifyTVar sbWarningsVar (. (t:))-- updateErrs exc = do- log' $ concat- [ display (piName sbPackageInfo)- , ": "- , tshow exc- ]- atomically $ modifyTVar sbErrsVar $ insertMap (piName sbPackageInfo) exc'- where- exc' =- case fromException exc of- Just bf -> bf- Nothing -> BuildFailureException exc--renameOrCopy :: FilePath -> FilePath -> IO ()-renameOrCopy src dest = rename src dest `catchIO` \_ -> copyDir src dest--copyBuiltInHaddocks :: FilePath -> IO ()-copyBuiltInHaddocks docdir = do- mghc <- findExecutable "ghc"- case mghc of- Nothing -> error "GHC not found on PATH"- Just ghc -> do- src <- canonicalizePath- (parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")- copyDir src docdir--------------- Previous results---- | The previous actions that can be run-data ResultType = Build | Haddock | Test- deriving (Show, Enum, Eq, Ord, Bounded, Read)---- | The result generated on a previous run-data PrevResult = PRNoResult | PRSuccess | PRFailure- deriving (Show, Enum, Eq, Ord, Bounded, Read)---- | Check if we should rerun based on a PrevResult and the expected status-checkPrevResult :: PrevResult -> TestState -> Bool-checkPrevResult _ Don'tBuild = False-checkPrevResult PRNoResult _ = True-checkPrevResult PRSuccess _ = False-checkPrevResult PRFailure ExpectSuccess = True-checkPrevResult PRFailure _ = False--withPRPath :: PerformBuild -> ResultType -> PackageIdentifier -> (FilePath -> IO a) -> IO a-withPRPath pb rt ident inner = do- createTree $ parent fp- inner fp- where- fp = pbPrevResDir pb </> fpFromString (show rt) </> fpFromText (display ident)--successBS, failureBS :: ByteString-successBS = "success"-failureBS = "failure"--getPreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> IO PrevResult-getPreviousResult w x y = withPRPath w x y $ \fp -> do- eres <- tryIO $ readFile fp- return $ case eres of- Right bs- | bs == successBS -> PRSuccess- | bs == failureBS -> PRFailure- _ -> PRNoResult--savePreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> Bool -> IO ()-savePreviousResult pb rt ident res =- withPRPath pb rt ident $ \fp -> writeFile fp $- if res then successBS else failureBS--deletePreviousResults :: PerformBuild -> PackageIdentifier -> IO ()-deletePreviousResults pb name =- forM_ [minBound..maxBound] $ \rt ->- withPRPath pb rt name $ \fp ->- void $ tryIO $ removeFile fp
− Stackage/Prelude.hs
@@ -1,116 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-module Stackage.Prelude- ( module X- , module Stackage.Prelude- ) where--import ClassyPrelude.Conduit as X-import Data.Aeson (FromJSON, ToJSON)-import Data.Conduit.Process as X-import qualified Data.Map as Map-import Data.Typeable (TypeRep, typeOf)-import Distribution.Package as X (PackageIdentifier (..), PackageName (PackageName))-import Distribution.PackageDescription as X (FlagName (..), GenericPackageDescription)-import qualified Distribution.Text as DT-import Distribution.Version as X (Version (..),- VersionRange)-import Distribution.Version as X (withinRange)-import qualified Distribution.Version as C-import Filesystem (createTree)-import Filesystem.Path (parent)-import qualified Filesystem.Path as F--unPackageName :: PackageName -> Text-unPackageName (PackageName str) = pack str--unFlagName :: FlagName -> Text-unFlagName (FlagName str) = pack str--mkPackageName :: Text -> PackageName-mkPackageName = PackageName . unpack--mkFlagName :: Text -> FlagName-mkFlagName = FlagName . unpack--display :: DT.Text a => a -> Text-display = fromString . DT.display--simpleParse :: (MonadThrow m, DT.Text a, Typeable a) => Text -> m a-simpleParse orig = withTypeRep $ \rep ->- case DT.simpleParse str of- Nothing -> throwM (ParseFailedException rep (pack str))- Just v -> return v- where- str = unpack orig-- withTypeRep :: Typeable a => (TypeRep -> m a) -> m a- withTypeRep f =- res- where- res = f (typeOf (unwrap res))-- unwrap :: m a -> a- unwrap _ = error "unwrap"--data ParseFailedException = ParseFailedException TypeRep Text- deriving (Show, Typeable)-instance Exception ParseFailedException--newtype Maintainer = Maintainer { unMaintainer :: Text }- deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString)---- | Name of an executable.-newtype ExeName = ExeName { unExeName :: Text }- deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString)--intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange-intersectVersionRanges x y = C.simplifyVersionRange $ C.intersectVersionRanges x y---- | There seems to be a bug in Cabal where serializing and deserializing--- version ranges winds up with different representations. So we have a--- super-simplifier to deal with that.-simplifyVersionRange :: VersionRange -> VersionRange-simplifyVersionRange vr =- fromMaybe (assert False vr') $ simpleParse $ display vr'- where- vr' = C.simplifyVersionRange vr---- | Topologically sort so that items with dependencies occur after those--- dependencies.-topologicalSort :: (Ord key, Show key, MonadThrow m, Typeable key)- => (value -> finalValue)- -> (value -> Set key) -- ^ deps- -> Map key value- -> m (Vector (key, finalValue))-topologicalSort toFinal toDeps =- loop id . mapWithKey removeSelfDeps . fmap (toDeps &&& toFinal)- where- removeSelfDeps k (deps, final) = (deleteSet k deps, final)- loop front toProcess | null toProcess = return $ pack $ front []- loop front toProcess- | null noDeps = throwM $ NoEmptyDeps (map fst toProcess')- | otherwise = loop (front . noDeps') (mapFromList hasDeps)- where- toProcess' = fmap (first removeUnavailable) toProcess- allKeys = Map.keysSet toProcess- removeUnavailable = asSet . setFromList . filter (`member` allKeys) . setToList- (noDeps, hasDeps) = partition (null . fst . snd) $ mapToList toProcess'- noDeps' = (map (second snd) noDeps ++)--data TopologicalSortException key = NoEmptyDeps (Map key (Set key))- deriving (Show, Typeable)-instance (Show key, Typeable key) => Exception (TopologicalSortException key)--copyDir :: FilePath -> FilePath -> IO ()-copyDir src dest =- runResourceT $ sourceDirectoryDeep False src $$ mapM_C go- where- src' = src </> ""- go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do- let dest' = dest </> suffix- liftIO $ createTree $ parent dest'- sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
− Stackage/ServerBundle.hs
@@ -1,271 +0,0 @@--- | Create a bundle to be uploaded to Stackage Server.-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-module Stackage.ServerBundle- ( serverBundle- , epochTime- , bpAllPackages- , docsListing- , createBundleV2- , CreateBundleV2 (..)- , SnapshotType (..)- , writeIndexStyle- , DocMap- , PackageDocs (..)- ) where--import qualified Codec.Archive.Tar as Tar-import qualified Codec.Archive.Tar.Entry as Tar-import qualified Codec.Compression.GZip as GZip-import qualified Data.Map as M-import Data.Aeson (ToJSON (..), (.=), object, FromJSON (..), (.:), withObject)-import System.IO.Temp (withTempDirectory)-import qualified Data.Yaml as Y-import Filesystem (isFile, getWorkingDirectory, listDirectory, isDirectory, canonicalizePath)-import Foreign.C.Types (CTime (CTime))-import Stackage.BuildConstraints-import Stackage.BuildPlan-import Stackage.Prelude-import System.IO.Temp (withTempDirectory)-import qualified System.PosixCompat.Time as PC-import qualified Text.XML as X-import Text.XML.Cursor-import System.PosixCompat.Files (createSymbolicLink)---- | Get current time-epochTime :: IO Tar.EpochTime-epochTime = (\(CTime t) -> fromIntegral t) <$> PC.epochTime---- | All package/versions in a build plan, including core packages.------ Note that this may include packages not available on Hackage.-bpAllPackages :: BuildPlan -> Map PackageName Version-bpAllPackages BuildPlan {..} =- siCorePackages bpSystemInfo ++ map ppVersion bpPackages--serverBundle :: Tar.EpochTime- -> Text -- ^ title- -> Text -- ^ slug- -> BuildPlan- -> LByteString-serverBundle time title slug bp@BuildPlan {..} = GZip.compress $ Tar.write- [ fe "build-plan.yaml" (fromStrict $ Y.encode bp)- , fe "hackage" hackage- , fe "slug" (fromStrict $ encodeUtf8 slug)- , fe "desc" (fromStrict $ encodeUtf8 title)- , fe "core" corePackagesList- ]- where- fe name contents =- case Tar.toTarPath False name of- Left s -> error s- Right name' -> (Tar.fileEntry name' contents)- { Tar.entryTime = time- }- hackage = builderToLazy $ foldMap goPair $ mapToList packageMap-- -- need to remove some packages that don't exist on Hackage- packageMap = foldr deleteMap (bpAllPackages bp) $ map PackageName- [ "bin-package-db"- , "ghc"- , "rts"- ]-- goPair (name, version) =- toBuilder (display name) ++- toBuilder (asText "-") ++- toBuilder (display version) ++- toBuilder (asText "\n")-- corePackagesList =- builderToLazy $ toBuilder $ unlines $- map (\(PackageName name) -> name)- (M.keys $ siCorePackages bpSystemInfo)---- | Package name is key-type DocMap = Map Text PackageDocs-data PackageDocs = PackageDocs- { pdVersion :: Text- , pdModules :: Map Text [Text]- -- ^ module name, path- }-instance ToJSON PackageDocs where- toJSON PackageDocs {..} = object- [ "version" .= pdVersion- , "modules" .= pdModules- ]-instance FromJSON PackageDocs where- parseJSON = withObject "PackageDocs" $ \o -> PackageDocs- <$> o .: "version"- <*> o .: "modules"--docsListing :: BuildPlan- -> FilePath -- ^ docs directory- -> IO DocMap-docsListing bp docsDir =- fmap fold $ mapM go $ mapToList $ bpAllPackages bp- where- go :: (PackageName, Version) -> IO DocMap- go (package, version) = do -- handleAny (const $ return mempty) $ do- let dirname = fpFromText (concat- [ display package- , "-"- , display version- ])- indexFP = (docsDir </> dirname </> "index.html")- ie <- isFile indexFP- if ie- then do- doc <- flip X.readFile indexFP X.def- { X.psDecodeEntities = X.decodeHtmlEntities- }- let cursor = fromDocument doc- getPair x = take 1 $ do- href <- attribute "href" x- let name = concat $ x $// content- guard $ not $ null name- return (href, name)- pairs = cursor $// attributeIs "class" "module"- &/ laxElement "a" >=> getPair- m <- fmap fold $ forM pairs $ \(href, name) -> do- let suffix = dirname </> fpFromText href- e <- isFile $ docsDir </> suffix- return $ if e- then asMap $ singletonMap name [fpToText dirname, href]- else mempty- return $ singletonMap (display package) $ PackageDocs- { pdVersion = display version- , pdModules = m- }- else return mempty--data SnapshotType = STNightly- | STLTS !Int !Int -- ^ major, minor- deriving (Show, Read, Eq, Ord)--instance ToJSON SnapshotType where- toJSON STNightly = object- [ "type" .= asText "nightly"- ]- toJSON (STLTS major minor) = object- [ "type" .= asText "lts"- , "major" .= major- , "minor" .= minor- ]-instance FromJSON SnapshotType where- parseJSON = withObject "SnapshotType" $ \o -> do- t <- o .: "type"- case asText t of- "nightly" -> return STNightly- "lts" -> STLTS- <$> o .: "major"- <*> o .: "minor"- _ -> fail $ "Unknown type for SnapshotType: " ++ unpack t--data CreateBundleV2 = CreateBundleV2- { cb2Plan :: BuildPlan- , cb2Type :: SnapshotType- , cb2DocsDir :: FilePath- , cb2Dest :: FilePath- }---- | Create a V2 bundle, which contains the build plan, metadata, docs, and doc--- map.-createBundleV2 :: CreateBundleV2 -> IO ()-createBundleV2 CreateBundleV2 {..} = do- docsDir <- canonicalizePath cb2DocsDir- docMap <- docsListing cb2Plan cb2DocsDir-- Y.encodeFile (fpToString $ docsDir </> "build-plan.yaml") cb2Plan- Y.encodeFile (fpToString $ docsDir </> "build-type.yaml") cb2Type- Y.encodeFile (fpToString $ docsDir </> "docs-map.yaml") docMap- void $ writeIndexStyle Nothing cb2DocsDir-- currentDir <- getWorkingDirectory- files <- listDirectory docsDir-- let args = "cfJ"- : fpToString (currentDir </> cb2Dest)- : "--dereference"- : map (fpToString . filename) files- cp = (proc "tar" args) { cwd = Just $ fpToString docsDir }- withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return ()--writeIndexStyle :: Maybe Text -- ^ snapshot id- -> FilePath -- ^ docs dir- -> IO [String]-writeIndexStyle msnapid dir = do- dirs <- fmap sort- $ runResourceT- $ sourceDirectory dir- $$ filterMC (liftIO . isDirectory)- =$ mapC (fpToString . filename)- =$ sinkList- writeFile (dir </> "index.html") $ mkIndex- (unpack <$> msnapid)- dirs- writeFile (dir </> "style.css") styleCss- return dirs--mkIndex :: Maybe String -> [String] -> String-mkIndex msnapid dirs = concat- [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"- , "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>"- , "<link rel='stylesheet' href='style.css'>"- , "<link rel='shortcut icon' href='http://www.stackage.org/static/img/favicon.ico' />"- , "</head>"- , "<body><div class='container'>"- , "<div class='row'><div class='span12 col-md-12'>"- , "<h1>Haddock documentation index</h1>"- , flip foldMap msnapid $ \snapid -> concat- [ "<p class='return'><a href=\"http://www.stackage.org/stackage/"- , snapid- , "\">Return to snapshot</a></p>"- ]- , "<ul>"- , concatMap toLI dirs- , "</ul></div></div></div></body></html>"- ]- where- toLI name = concat- [ "<li><a href='"- , name- , "/index.html'>"- , name- , "</a></li>"- ]--styleCss :: String-styleCss = concat- [ "@media (min-width: 530px) {"- , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"- , "}"- , "@media (min-width: 760px) {"- , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"- , "}"- , "ul {"- , " margin-left: 0;"- , " padding-left: 0;"- , " list-style-type: none;"- , "}"- , "body {"- , " background: #f0f0f0;"- , " font-family: 'Lato', sans-serif;"- , " text-shadow: 1px 1px 1px #ffffff;"- , " font-size: 20px;"- , " line-height: 30px;"- , " padding-bottom: 5em;"- , "}"- , "h1 {"- , " font-weight: normal;"- , " color: #06537d;"- , " font-size: 45px;"- , "}"- , ".return a {"- , " color: #06537d;"- , " font-style: italic;"- , "}"- , ".return {"- , " margin-bottom: 1em;"- , "}"]
− Stackage/UpdateBuildPlan.hs
@@ -1,54 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--- | Take an existing build plan and bump all packages to the newest version in--- the same major version number.-module Stackage.UpdateBuildPlan- ( updateBuildConstraints- , updateBuildPlan- ) where--import qualified Data.Map as Map-import Distribution.Version (anyVersion, earlierVersion,- orLaterVersion)-import Stackage.BuildConstraints-import Stackage.BuildPlan-import Stackage.Prelude--updateBuildPlan :: Map PackageName PackagePlan -> BuildPlan -> IO BuildPlan-updateBuildPlan packagesOrig- = newBuildPlan packagesOrig . updateBuildConstraints--updateBuildConstraints :: BuildPlan -> BuildConstraints-updateBuildConstraints BuildPlan {..} =- BuildConstraints {..}- where- bcSystemInfo = bpSystemInfo- bcPackages = Map.keysSet bpPackages- bcGithubUsers = bpGithubUsers-- bcPackageConstraints name = PackageConstraints- { pcVersionRange = addBumpRange (maybe anyVersion pcVersionRange moldPC)- , pcMaintainer = moldPC >>= pcMaintainer- , pcTests = maybe ExpectSuccess pcTests moldPC- , pcHaddocks = maybe ExpectSuccess pcHaddocks moldPC- , pcBuildBenchmarks = maybe True pcBuildBenchmarks moldPC- , pcFlagOverrides = maybe mempty pcFlagOverrides moldPC- , pcEnableLibProfile = maybe False pcEnableLibProfile moldPC- }- where- moldBP = lookup name bpPackages- moldPC = ppConstraints <$> moldBP-- addBumpRange oldRange =- case moldBP of- Nothing -> oldRange- Just bp -> intersectVersionRanges oldRange- $ bumpRange $ ppVersion bp-- bumpRange version = intersectVersionRanges- (orLaterVersion version)- (earlierVersion $ bumpVersion version)- bumpVersion (Version (x:y:_) _) = Version [x, y + 1] []- bumpVersion (Version [x] _) = Version [x, 1] []- bumpVersion (Version [] _) = assert False $ Version [1, 0] []
− Stackage/Upload.hs
@@ -1,271 +0,0 @@--- | Upload to Stackage and Hackage-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-module Stackage.Upload- ( UploadBundle (..)- , SnapshotIdent (..)- , uploadBundle- , UploadDocs (..)- , uploadDocs- , uploadHackageDistro- , uploadHackageDistroNamed- , UploadDocMap (..)- , uploadDocMap- , uploadBundleV2- , UploadBundleV2 (..)- , def- , unStackageServer- ) where--import Control.Monad.Writer.Strict (execWriter, tell)-import Data.Default.Class (Default (..))-import Data.Function (fix)-import Filesystem (isDirectory, isFile)-import Network.HTTP.Client-import qualified Network.HTTP.Client.Conduit as HCC-import Network.HTTP.Client.MultipartFormData-import Stackage.BuildPlan (BuildPlan)-import Stackage.Prelude-import Stackage.ServerBundle (bpAllPackages, docsListing, writeIndexStyle)-import System.IO.Temp (withSystemTempFile)-import qualified System.IO as IO-import qualified Data.Yaml as Y--newtype StackageServer = StackageServer { unStackageServer :: Text }- deriving (Show, Eq, Ord, Hashable, IsString)-instance Default StackageServer where- def = "http://www.stackage.org"--data UploadBundle = UploadBundle- { ubServer :: StackageServer- , ubContents :: LByteString- , ubAlias :: Maybe Text- , ubNightly :: Maybe Text -- ^ should be GHC version- , ubLTS :: Maybe Text -- ^ e.g. 2.3- , ubAuthToken :: Text- }-instance Default UploadBundle where- def = UploadBundle- { ubServer = def- , ubContents = mempty- , ubAlias = Nothing- , ubNightly = Nothing- , ubLTS = Nothing- , ubAuthToken = "no-auth-token-provided"- }--newtype SnapshotIdent = SnapshotIdent { unSnapshotIdent :: Text }- deriving (Show, Eq, Ord, Hashable, IsString)--uploadBundle :: UploadBundle -> Manager -> IO (SnapshotIdent, Maybe Text)-uploadBundle UploadBundle {..} man = do- req1 <- parseUrl $ unpack $ unStackageServer ubServer ++ "/upload"- req2 <- formDataBody formData req1- let req3 = req2- { method = "PUT"- , requestHeaders =- [ ("Authorization", encodeUtf8 ubAuthToken)- , ("Accept", "application/json")- ] ++ requestHeaders req2- , redirectCount = 0- , checkStatus = \_ _ _ -> Nothing- , responseTimeout = Just 300000000- }- res <- httpLbs req3 man- case lookup "x-stackage-ident" $ responseHeaders res of- Just snapid -> return- ( SnapshotIdent $ decodeUtf8 snapid- , decodeUtf8 <$> lookup "location" (responseHeaders res)- )- Nothing -> error $ "An error occurred: " ++ show res- where- params = mapMaybe (\(x, y) -> (x, ) <$> y)- [ ("alias", ubAlias)- , ("nightly", ubNightly)- , ("lts", ubLTS)- ]- formData = ($ []) $ execWriter $ do- forM_ params $ \(key, value) ->- tell' $ partBS key $ encodeUtf8 value- tell' $ partFileRequestBody "stackage" "stackage"- $ RequestBodyLBS ubContents-- tell' x = tell (x:)--data UploadDocs = UploadDocs- { udServer :: StackageServer- , udDocs :: FilePath -- ^ may be a directory or a tarball- , udAuthToken :: Text- , udSnapshot :: SnapshotIdent- }--uploadDocs :: UploadDocs -> Manager -> IO (Response LByteString)-uploadDocs (UploadDocs (StackageServer host) fp0 token ident) man = do- fe <- isFile fp0- if fe- then uploadDocsFile $ fpToString fp0- else do- de <- isDirectory fp0- if de- then uploadDocsDir- else error $ "Path not found: " ++ fpToString fp0- where- uploadDocsDir = withSystemTempFile "haddocks.tar.xz" $ \fp h -> do- hClose h- dirs <- writeIndexStyle (Just $ unSnapshotIdent ident) fp0- let cp = (proc "tar" $ "cJf" : fp : "index.html" : "style.css" : dirs)- { cwd = Just $ fpToString fp0- }- withCheckedProcess cp $ \Inherited Inherited Inherited -> return ()- uploadDocsFile fp- uploadDocsFile fp = do- req1 <- parseUrl $ unpack $ concat- [ host- , "/upload-haddock/"- , unSnapshotIdent ident- ]- let formData =- [ partFileSource "tarball" fp- ]- req2 <- formDataBody formData req1- let req3 = req2- { method = "PUT"- , requestHeaders =- [ ("Authorization", encodeUtf8 token)- , ("Accept", "application/json")- ] ++ requestHeaders req2- , redirectCount = 0- , checkStatus = \_ _ _ -> Nothing- , responseTimeout = Just 300000000- }- httpLbs req3 man--uploadHackageDistro :: BuildPlan- -> ByteString -- ^ Hackage username- -> ByteString -- ^ Hackage password- -> Manager- -> IO (Response LByteString)-uploadHackageDistro = uploadHackageDistroNamed "Stackage"--uploadHackageDistroNamed- :: Text -- ^ distro name- -> BuildPlan- -> ByteString -- ^ Hackage username- -> ByteString -- ^ Hackage password- -> Manager- -> IO (Response LByteString)-uploadHackageDistroNamed name bp username password manager = do- req1 <- parseUrl $ concat- [ "http://hackage.haskell.org/distro/"- , unpack name- , "/packages.csv"- ]- let req2 = req1- { requestHeaders = [("Content-Type", "text/csv")]- , requestBody = RequestBodyLBS csv- , checkStatus = \_ _ _ -> Nothing- , method = "PUT"- }- httpLbs (applyBasicAuth username password req2) manager- where- csv = encodeUtf8- $ builderToLazy- $ mconcat- $ intersperse "\n"- $ map go- $ mapToList- $ bpAllPackages bp- go (name, version) =- "\"" ++- (toBuilder $ display name) ++- "\",\"" ++- (toBuilder $ display version) ++- "\",\"http://www.stackage.org/package/" ++- (toBuilder $ display name) ++- "\""--data UploadDocMap = UploadDocMap- { udmServer :: StackageServer- , udmAuthToken :: Text- , udmSnapshot :: SnapshotIdent- , udmDocDir :: FilePath- , udmPlan :: BuildPlan- }--uploadDocMap :: UploadDocMap -> Manager -> IO (Response LByteString)-uploadDocMap UploadDocMap {..} man = do- docmap <- docsListing udmPlan udmDocDir- req1 <- parseUrl $ unpack $ unStackageServer udmServer ++ "/upload-doc-map"- req2 <- formDataBody (formData $ Y.encode docmap) req1- let req3 = req2- { method = "PUT"- , requestHeaders =- [ ("Authorization", encodeUtf8 udmAuthToken)- , ("Accept", "application/json")- ] ++ requestHeaders req2- , redirectCount = 0- , checkStatus = \_ _ _ -> Nothing- , responseTimeout = Just 300000000- }- httpLbs req3 man- where- formData docmap =- [ partBS "snapshot" (encodeUtf8 $ unSnapshotIdent udmSnapshot)- , partFileRequestBody "docmap" "docmap" $ RequestBodyBS docmap- ]--data UploadBundleV2 = UploadBundleV2- { ub2Server :: StackageServer- , ub2AuthToken :: Text- , ub2Bundle :: FilePath- }--uploadBundleV2 :: UploadBundleV2 -> Manager -> IO Text-uploadBundleV2 UploadBundleV2 {..} man = IO.withBinaryFile (fpToString ub2Bundle) IO.ReadMode $ \h -> do- size <- IO.hFileSize h- putStrLn $ "Bundle size: " ++ tshow size- req1 <- parseUrl $ unpack $ unStackageServer ub2Server ++ "/upload2"- let req2 = req1- { method = "PUT"- , requestHeaders =- [ ("Authorization", encodeUtf8 ub2AuthToken)- , ("Accept", "application/json")- , ("Content-Type", "application/x-tar")- ]- , requestBody = HCC.requestBodySource (fromIntegral size)- $ sourceHandle h $= printProgress size- }- sink = decodeUtf8C =$ fix (\loop -> do- mx <- peekC- case mx of- Nothing -> error $ "uploadBundleV2: premature end of stream"- Just _ -> do- l <- lineC $ takeCE 4096 =$ foldC- let (cmd, msg') = break (== ':') l- msg = dropWhile (== ' ') $ dropWhile (== ':') msg'- case cmd of- "CONT" -> do- putStrLn msg- loop- "FAILURE" -> error $ "uploadBundleV2 failed: " ++ unpack msg- "SUCCESS" -> return msg- _ -> error $ "uploadBundleV2: unknown command " ++ unpack cmd- )- withResponse req2 man $ \res -> HCC.bodyReaderSource (responseBody res) $$ sink- where- printProgress total =- loop 0 0- where- loop sent lastPercent =- await >>= maybe (putStrLn "Upload complete") go- where- go bs = do- yield bs- let sent' = sent + fromIntegral (length bs)- percent = sent' * 100 `div` total- when (percent /= lastPercent)- $ putStrLn $ "Upload progress: " ++ tshow percent ++ "%"- loop sent' percent
− app/stackage.hs
@@ -1,195 +0,0 @@-{-# LANGUAGE TupleSections #-}--module Main where--import Control.Monad-import Data.Monoid-import Data.String (fromString)-import Data.Version-import Options.Applicative-import Filesystem.Path.CurrentOS (decodeString)-import Paths_stackage (version)-import Stackage.CompleteBuild-import Stackage.Upload-import Stackage.InstallBuild-import Network.HTTP.Client (withManager)-import Network.HTTP.Client.TLS (tlsManagerSettings)-import qualified Data.Text as T--main :: IO ()-main =- join $- execParser $- info- (helpOption <*> versionOption <*> config)- (header "Stackage" <>- fullDesc)- where- helpOption =- abortOption ShowHelpText $- long "help" <>- help "Show this help text"- versionOption =- infoOption- ("stackage version " ++ showVersion version)- (long "version" <>- help "Show stackage version")- config =- subparser $- mconcat- [ cmnd- (uncurry completeBuild)- (fmap (Nightly, ) buildFlags)- "nightly"- "Build, test and upload the Nightly snapshot"- , cmnd- (uncurry completeBuild)- (fmap (LTS Major, ) buildFlags)- "lts-major"- "Build, test and upload the LTS (major) snapshot"- , cmnd- (uncurry completeBuild)- (fmap (LTS Minor, ) buildFlags)- "lts-minor"- "Build, test and upload the LTS (minor) snapshot"- , cmnd- justUploadNightly- nightlyUploadFlags- "upload-nightly"- "Upload an already-built nightly snapshot"- , cmnd- (const justCheck)- (pure ())- "check"- "Just check that the build plan is ok"- , cmnd- installBuild- installFlags- "install"- "Install a snapshot from an existing build plan"- , cmnd- uploadv2- uploadv2Flags- "upload2"- "Upload a pre-existing v2 bundle"- ]-- cmnd exec parse name desc =- command name $- info- (fmap exec (parse <**> helpOption))- (progDesc desc)-- buildFlags =- BuildFlags <$>- fmap- not- (switch- (long "skip-tests" <>- help "Skip build and running the test suites")) <*>- fmap- not- (switch- (long "skip-haddock" <>- help "Skip generating haddock documentation")) <*>- fmap- not- (switch- (long "skip-upload" <>- help "Skip uploading bundle, docs, etc.")) <*>- switch- (long "enable-library-profiling" <>- help "Enable profiling when building") <*>- switch- (long "enable-executable-dynamic" <>- help "Enable dynamic executables when building") <*>- switch- (long "verbose" <> short 'v' <>- help "Output verbose detail about the build steps") <*>- switch- (long "skip-check" <>- help "Skip the check phase, and pass --allow-newer to cabal configure") <*>- switch- (long "upload-v2" <>- help "Use the V2 upload code")-- nightlyUploadFlags = fromString <$> strArgument- (metavar "DATE" <>- help "Date, in YYYY-MM-DD format")-- installFlags =- InstallFlags <$>- (fmap- BPSBundleWeb- (strOption- (long "bundle" <>- metavar "URL" <>- help "Stackage bundle containing build plan")) <|>- fmap- (BPSFile . decodeString)- (strOption- (long "build-plan" <>- metavar "PATH" <>- help "Build-plan YAML file"))) <*>- fmap- decodeString- (strArgument- (metavar "DESTINATION-PATH" <>- help "Destination directory path")) <*>- (fmap- (Just . decodeString)- (strOption- (long "log-dir" <>- metavar "PATH" <>- help "Location of log files (default DESTINATION-PATH/logs)")) <|>- pure Nothing) <*>- option- auto- (long "jobs" <>- metavar "NUMBER" <>- showDefault <> value 8 <>- help "Number of threads") <*>- switch- (long "global" <>- help "Install in global package database") <*>- fmap- not- (switch- (long "skip-tests" <>- help "Skip build and running the test suites")) <*>- fmap- not- (switch- (long "skip-haddock" <>- help "Skip generating haddock documentation")) <*>- switch- (long "enable-library-profiling" <>- help "Enable profiling when building") <*>- switch- (long "enable-executable-dynamic" <>- help "Enable dynamic executables when building") <*>- switch- (long "verbose" <> short 'v' <>- help "Output verbose detail about the build steps") <*>- switch- (long "skip-check" <>- help "Skip the check phase, and pass --allow-newer to cabal configure")-- uploadv2 (path, url) = withManager tlsManagerSettings $ \man -> do- token <- getStackageAuthToken- res <- flip uploadBundleV2 man UploadBundleV2- { ub2AuthToken = token- , ub2Server = fromString url- , ub2Bundle = decodeString path- }- putStrLn $ "New URL: " ++ T.unpack res-- uploadv2Flags = (,)- <$> (strArgument- (metavar "BUNDLE-PATH" <>- help "Bundle path"))- <*> strOption- (long "server-url" <>- metavar "SERVER-URL" <>- showDefault <> value (T.unpack $ unStackageServer def) <>- help "Server to upload bundle to")
stackage.cabal view
@@ -1,105 +1,23 @@ name: stackage-version: 0.6.0.1-synopsis: "Stable Hackage," tools for creating a vetted set of packages from Hackage.-description: Please see <http://www.stackage.org/package/stackage> for a description and documentation.-homepage: https://github.com/fpco/stackage+version: 0.7.0.0+synopsis: Dummy package forcing installation of other Stackage packages+homepage: https://www.stackage.org/ license: MIT license-file: LICENSE author: Michael Snoyman-maintainer: michael@fpcomplete.com-category: Distribution+maintainer: michael@snoyman.com+category: Development build-type: Simple+extra-source-files: README.md ChangeLog.md cabal-version: >=1.10-extra-source-files: README.md- ChangeLog.md- test/test-build-constraints.yaml library+ exposed-modules: Stackage.Dummy+ build-depends: base < 10+ , stackage-cli+ , stackage-update default-language: Haskell2010- exposed-modules: Stackage.Prelude- Stackage.BuildConstraints- Stackage.CorePackages- Stackage.PackageIndex- Stackage.BuildPlan- Stackage.CheckBuildPlan- Stackage.UpdateBuildPlan- Stackage.GhcPkg- Stackage.GithubPings- Stackage.InstallBuild- Stackage.PackageDescription- Stackage.ServerBundle- Stackage.Upload- Stackage.PerformBuild- Stackage.CompleteBuild- build-depends: base >= 4 && < 5- , containers- , Cabal >= 1.14- , tar >= 0.3- , zlib- , bytestring- , directory- , filepath- , transformers- , process- , old-locale- , time- , utf8-string - , conduit-extra- , classy-prelude-conduit- , text- , system-fileio- , system-filepath- , mtl- , aeson- , yaml- , unix-compat- , http-client- , http-conduit- , http-client-tls- , temporary- , data-default-class- , stm- , mono-traversable- , async- , streaming-commons >= 0.1.7.1- , semigroups- , xml-conduit- , conduit--executable stackage- default-language: Haskell2010- hs-source-dirs: app- main-is: stackage.hs- build-depends: base- , stackage- , optparse-applicative >= 0.11- , system-filepath- , http-client- , http-client-tls- , text- ghc-options: -rtsopts -threaded -with-rtsopts=-N--test-suite spec- type: exitcode-stdio-1.0- default-language: Haskell2010- hs-source-dirs: test- main-is: Spec.hs- other-modules: Stackage.CorePackagesSpec- Stackage.PackageIndexSpec- Stackage.BuildPlanSpec- build-depends: base- , stackage- , hspec- , QuickCheck- , text- , classy-prelude-conduit- , Cabal- , yaml- , containers- , http-client- , http-client-tls- source-repository head type: git- location: https://github.com/fpco/stackage+ location: git://github.com/fpco/stackage.git
− test/Spec.hs
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
− test/Stackage/BuildPlanSpec.hs
@@ -1,143 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}-module Stackage.BuildPlanSpec (spec) where--import qualified Data.Map as Map-import qualified Data.Map.Strict as M-import qualified Data.Set as S-import Data.Yaml-import qualified Data.Yaml as Y-import Distribution.Version-import Network.HTTP.Client-import Network.HTTP.Client.TLS (tlsManagerSettings)-import Stackage.BuildConstraints-import Stackage.BuildPlan-import Stackage.CheckBuildPlan-import Stackage.PackageDescription-import Stackage.Prelude-import Stackage.UpdateBuildPlan-import Test.Hspec--spec :: Spec-spec = do- it "simple package set" $ check testBuildConstraints $ makePackageSet- [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])])- ,("bar", [0, 0, 0], [])]- it "bad version range on depdendency fails" $ badBuildPlan $ makePackageSet- [("foo", [0, 0, 0], [("bar", thisV [1, 1, 0])])- ,("bar", [0, 0, 0], [])]- it "nonexistent package fails to check" $ badBuildPlan $ makePackageSet- [("foo", [0, 0, 0], [("nonexistent", thisV [0, 0, 0])])- ,("bar", [0, 0, 0], [])]- it "mutual cycles fail to check" $ badBuildPlan $ makePackageSet- [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])])- ,("bar", [0, 0, 0], [("foo", thisV [0, 0, 0])])]- it "nested cycles fail to check" $ badBuildPlan $ makePackageSet- [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])])- ,("bar", [0, 0, 0], [("mu", thisV [0, 0, 0])])- ,("mu", [0, 0, 0], [("foo", thisV [0, 0, 0])])]- {- Shouldn't be testing this actually- it "default package set checks ok" $- check defaultBuildConstraints getLatestAllowedPlans- -}---- | Checking should be considered a bad build plan.-badBuildPlan :: (BuildConstraints -> IO (Map PackageName PackagePlan))- -> void- -> IO ()-badBuildPlan m _ = do- mu <- try (check testBuildConstraints m)- case mu of- Left (_ :: BadBuildPlan) ->- return ()- Right () ->- error "Expected bad build plan."---- | Check build plan with the given package set getter.-check :: (Manager -> IO BuildConstraints)- -> (BuildConstraints -> IO (Map PackageName PackagePlan))- -> IO ()-check readPlanFile getPlans = withManager tlsManagerSettings $ \man -> do- bc <- readPlanFile man- plans <- getPlans bc- bp <- newBuildPlan plans bc- let bs = Y.encode bp- ebp' = Y.decodeEither bs-- bp' <- either error return ebp'-- let allPackages = Map.keysSet (bpPackages bp) ++ Map.keysSet (bpPackages bp')- forM_ allPackages $ \name ->- (name, lookup name (bpPackages bp')) `shouldBe`- (name, lookup name (bpPackages bp))- bpGithubUsers bp' `shouldBe` bpGithubUsers bp-- when (bp' /= bp) $ error "bp' /= bp"- bp2 <- updateBuildPlan plans bp- when (dropVersionRanges bp2 /= dropVersionRanges bp) $ error "bp2 /= bp"- checkBuildPlan bp- where- dropVersionRanges bp =- bp { bpPackages = map go $ bpPackages bp }- where- go pb = pb { ppConstraints = go' $ ppConstraints pb }- go' pc = pc { pcVersionRange = anyVersion }---- | Make a package set from a convenient data structure.-makePackageSet- :: [(String,[Int],[(String,VersionRange)])]- -> BuildConstraints- -> IO (Map PackageName PackagePlan)-makePackageSet ps _ =- return $- M.fromList $- map- (\(name,ver,deps) ->- ( PackageName name- , dummyPackage ver $- M.fromList $- map- (\(dname,dver) ->- ( PackageName dname- , DepInfo {diComponents = S.fromList- [CompLibrary]- ,diRange = dver}))- deps))- ps- where- dummyPackage v deps =- PackagePlan- {ppVersion = Version v []- ,ppGithubPings = mempty- ,ppUsers = mempty- ,ppConstraints =- PackageConstraints- {pcVersionRange = anyV- ,pcMaintainer = Nothing- ,pcTests = Don'tBuild- ,pcHaddocks = Don'tBuild- ,pcBuildBenchmarks = False- ,pcFlagOverrides = mempty- ,pcEnableLibProfile = False}- ,ppDesc =- SimpleDesc- {sdPackages = deps- ,sdTools = mempty- ,sdProvidedExes = mempty- ,sdModules = mempty}}---- | This exact version is required.-thisV :: [Int] -> VersionRange-thisV ver = thisVersion (Version ver [])---- | Accept any version.-anyV :: VersionRange-anyV = anyVersion---- | Test plan.-testBuildConstraints :: void -> IO BuildConstraints-testBuildConstraints _ =- decodeFileEither- (fpToString fp) >>=- either throwIO toBC- where fp = "test/test-build-constraints.yaml"
− test/Stackage/CorePackagesSpec.hs
@@ -1,19 +0,0 @@-{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}-module Stackage.CorePackagesSpec (spec) where--import Stackage.CorePackages-import Stackage.Prelude-import Test.Hspec--spec :: Spec-spec = do- it "works" $ void getCorePackages- it "contains known core packages" $ do- m <- getCorePackages- forM_ (words "ghc containers base") $ \p ->- m `shouldSatisfy` (member (PackageName p))- it "getCoreExecutables includes known executables" $ do- s <- getCoreExecutables- s `shouldSatisfy` member "ghc"- s `shouldSatisfy` member "hsc2hs"- s `shouldSatisfy` member "runghc"
− test/Stackage/PackageIndexSpec.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}-module Stackage.PackageIndexSpec (spec) where--import Stackage.PackageIndex-import Stackage.Prelude-import Test.Hspec-import Distribution.Package (packageId)--spec :: Spec-spec = do- it "works" $ (runResourceT $ sourcePackageIndex $$ sinkNull :: IO ())- it "getLatestDescriptions gives reasonable results" $ do- let f x y = (display x, display y) `member` asSet (setFromList- [ (asText "base", asText "4.5.0.0")- , ("does-not-exist", "9999999999999999999")- ])- m <- getLatestDescriptions f return- length m `shouldBe` 1- p <- simpleParse $ asText "base"- v <- simpleParse $ asText "4.5.0.0"- (pkgVersion . packageId <$> m) `shouldBe` singletonMap p v
− test/test-build-constraints.yaml
@@ -1,20 +0,0 @@-packages:- "Test":- - foo- - bar--global-flags: []--skipped-tests: []-expected-test-failures: []-expected-haddock-failures: []-skipped-benchmarks: []-skipped-profiling: []--github-users:- bar:- - demo--package-flags:- foo:- demo: true