diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs deleted file mode 100644 --- a/Stackage/BuildConstraints.hs +++ /dev/null @@ -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 diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs deleted file mode 100644 --- a/Stackage/BuildPlan.hs +++ /dev/null @@ -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) diff --git a/Stackage/CheckBuildPlan.hs b/Stackage/CheckBuildPlan.hs deleted file mode 100644 --- a/Stackage/CheckBuildPlan.hs +++ /dev/null @@ -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 diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs deleted file mode 100644 --- a/Stackage/CompleteBuild.hs +++ /dev/null @@ -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 diff --git a/Stackage/CorePackages.hs b/Stackage/CorePackages.hs deleted file mode 100644 --- a/Stackage/CorePackages.hs +++ /dev/null @@ -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 diff --git a/Stackage/Dummy.hs b/Stackage/Dummy.hs new file mode 100644 --- /dev/null +++ b/Stackage/Dummy.hs @@ -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 diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs deleted file mode 100644 --- a/Stackage/GhcPkg.hs +++ /dev/null @@ -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: " diff --git a/Stackage/GithubPings.hs b/Stackage/GithubPings.hs deleted file mode 100644 --- a/Stackage/GithubPings.hs +++ /dev/null @@ -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 - _ -> [] diff --git a/Stackage/InstallBuild.hs b/Stackage/InstallBuild.hs deleted file mode 100644 --- a/Stackage/InstallBuild.hs +++ /dev/null @@ -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" diff --git a/Stackage/PackageDescription.hs b/Stackage/PackageDescription.hs deleted file mode 100644 --- a/Stackage/PackageDescription.hs +++ /dev/null @@ -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 - } diff --git a/Stackage/PackageIndex.hs b/Stackage/PackageIndex.hs deleted file mode 100644 --- a/Stackage/PackageIndex.hs +++ /dev/null @@ -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 diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs deleted file mode 100644 --- a/Stackage/PerformBuild.hs +++ /dev/null @@ -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 diff --git a/Stackage/Prelude.hs b/Stackage/Prelude.hs deleted file mode 100644 --- a/Stackage/Prelude.hs +++ /dev/null @@ -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) ()) diff --git a/Stackage/ServerBundle.hs b/Stackage/ServerBundle.hs deleted file mode 100644 --- a/Stackage/ServerBundle.hs +++ /dev/null @@ -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 - [ "\nHaddocks index" - , "" - , "" - , "" - , "" - , "
" - , "
" - , "

Haddock documentation index

" - , flip foldMap msnapid $ \snapid -> concat - [ "

Return to snapshot

" - ] - , "
    " - , concatMap toLI dirs - , "
" - ] - where - toLI name = concat - [ "
  • " - , name - , "
    • " - ] - -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;" - , "}"] diff --git a/Stackage/UpdateBuildPlan.hs b/Stackage/UpdateBuildPlan.hs deleted file mode 100644 --- a/Stackage/UpdateBuildPlan.hs +++ /dev/null @@ -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] [] diff --git a/Stackage/Upload.hs b/Stackage/Upload.hs deleted file mode 100644 --- a/Stackage/Upload.hs +++ /dev/null @@ -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 diff --git a/app/stackage.hs b/app/stackage.hs deleted file mode 100644 --- a/app/stackage.hs +++ /dev/null @@ -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") diff --git a/stackage.cabal b/stackage.cabal --- a/stackage.cabal +++ b/stackage.cabal @@ -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 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 diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Stackage/BuildPlanSpec.hs b/test/Stackage/BuildPlanSpec.hs deleted file mode 100644 --- a/test/Stackage/BuildPlanSpec.hs +++ /dev/null @@ -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" diff --git a/test/Stackage/CorePackagesSpec.hs b/test/Stackage/CorePackagesSpec.hs deleted file mode 100644 --- a/test/Stackage/CorePackagesSpec.hs +++ /dev/null @@ -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" diff --git a/test/Stackage/PackageIndexSpec.hs b/test/Stackage/PackageIndexSpec.hs deleted file mode 100644 --- a/test/Stackage/PackageIndexSpec.hs +++ /dev/null @@ -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 diff --git a/test/test-build-constraints.yaml b/test/test-build-constraints.yaml deleted file mode 100644 --- a/test/test-build-constraints.yaml +++ /dev/null @@ -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