diff --git a/.dir-locals.el b/.dir-locals.el
new file mode 100644
index 00000000..101363c1
--- /dev/null
+++ b/.dir-locals.el
@@ -0,0 +1,3 @@
+((haskell-mode . ((haskell-process-type . cabal-repl)
+ (haskell-indent-spaces . 4)
+ (hindent-style . "johan-tibell"))))
diff --git a/.dockerignore b/.dockerignore
new file mode 100644
index 00000000..383463ca
--- /dev/null
+++ b/.dockerignore
@@ -0,0 +1,8 @@
+dist
+builds
+logs
+.cabal-sandbox
+cabal.sandbox.config
+tarballs
+*.yaml
+.git
diff --git a/.gitignore b/.gitignore
index a153cdeb..0f9f8e70 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,13 +1,5 @@
-dist
-*.o
-*.hi
-*.chi
-*.chs.h
-*.swp
/builds/
/logs/
-/.cabal-sandbox/
-cabal.sandbox.config
nightly-*.yaml
lts-*.yaml
-/tarballs/
+*.swp
diff --git a/.travis.yml b/.travis.yml
new file mode 100644
index 00000000..70421914
--- /dev/null
+++ b/.travis.yml
@@ -0,0 +1,21 @@
+env:
+ - CABALVER=1.22 GHCVER=7.10.1
+
+# Note: the distinction between `before_install` and `install` is not important.
+before_install:
+ - travis_retry sudo add-apt-repository -y ppa:hvr/ghc
+ - travis_retry sudo apt-get update
+ - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex
+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
+
+install:
+ - cabal --version
+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
+ - travis_retry cabal update
+ - wget https://s3.amazonaws.com/stackage-travis/stackage-curator/stackage-curator.bz2
+ - bunzip2 stackage-curator.bz2
+ - chmod +x stackage-curator
+
+# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.
+script:
+ - ./stackage-curator check
diff --git a/ChangeLog.md b/ChangeLog.md
deleted file mode 100644
index 2a524e11..00000000
--- a/ChangeLog.md
+++ /dev/null
@@ -1,34 +0,0 @@
-## 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
-
-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.
diff --git a/Dockerfile b/Dockerfile
new file mode 100644
index 00000000..1b7d3066
--- /dev/null
+++ b/Dockerfile
@@ -0,0 +1,23 @@
+FROM ubuntu:14.04
+
+ENV HOME /home/stackage
+ENV LANG en_US.UTF-8
+
+RUN mkdir /home/stackage -p
+RUN locale-gen en_US.UTF-8
+
+RUN DEBIAN_FRONTEND=noninteractive apt-get update
+RUN DEBIAN_FRONTEND=noninteractive apt-get install -y software-properties-common python-software-properties git
+RUN DEBIAN_FRONTEND=noninteractive add-apt-repository ppa:hvr/ghc -y
+
+ADD debian-bootstrap.sh /tmp/debian-bootstrap.sh
+RUN DEBIAN_FRONTEND=noninteractive bash /tmp/debian-bootstrap.sh
+RUN rm /tmp/debian-bootstrap.sh
+
+RUN DEBIAN_FRONTEND=noninteractive apt-get install -y cabal-install-1.22 ghc-7.10.1 ghc-7.10.1-htmldocs alex-3.1.3 happy-1.19.4 sudo
+
+ENV PATH /home/stackage/.cabal/bin:/usr/local/sbin:/usr/local/bin:/opt/ghc/7.10.1/bin:/opt/cabal/1.22/bin:/opt/alex/3.1.3/bin:/opt/happy/1.19.4/bin:/usr/sbin:/usr/bin:/sbin:/bin
+
+RUN cabal update
+RUN cabal install hscolour cabal-install && cp $HOME/.cabal/bin/* /usr/local/bin && rm -rf $HOME/.cabal $HOME/.ghc /tmp/stackage
+RUN wget https://s3.amazonaws.com/stackage-travis/stackage-curator/stackage-curator.bz2 && bunzip2 stackage-curator.bz2 && chmod +x stackage-curator && mv stackage-curator /usr/local/bin
diff --git a/README.md b/README.md
index 013e3209..5b15fd98 100644
--- a/README.md
+++ b/README.md
@@ -1,16 +1,28 @@
stackage
========
+[](https://travis-ci.org/fpco/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.
+The Stackage project consists of multiple repositories. This repository
+contains the metadata on packages to be included in future builds and some
+project information. In addition, we have the following repositories:
+
+* [stackage-server](https://github.com/fpco/stackage-server) [](https://travis-ci.org/fpco/stackage-server)
+* [stackage-curator](https://github.com/fpco/stackage-curator) [](https://travis-ci.org/fpco/stackage-curator)
+* [stackage-types](https://github.com/fpco/stackage-types) [](https://travis-ci.org/fpco/stackage-types)
+* [lts-haskell](https://github.com/fpco/lts-haskell)
+* [stackage-nightly](https://github.com/fpco/stackage-nightly)
+* [stackage-cli](https://github.com/fpco/stackage-cli) [](https://travis-ci.org/fpco/stackage-cli)
+* [stackage-update](https://github.com/fpco/stackage-update) [](https://travis-ci.org/fpco/stackage-update)
+* [stackage-upload](https://github.com/fpco/stackage-upload) [](https://travis-ci.org/fpco/stackage-upload)
+* [stackage-install](https://github.com/fpco/stackage-install) [](https://travis-ci.org/fpco/stackage-install)
+* [stackage-build-plan](https://github.com/fpco/stackage-build-plan) [](https://travis-ci.org/fpco/stackage-build-plan)
Get your package included
-------------------------
@@ -37,6 +49,23 @@ 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).
+Package Author Guidelines
+-------------------------
+
+There are some basic rules to get your package to play nice with Stackage. Here
+are some quick guidelines to hopefully make this easier:
+
+* Make sure that your code is buildability and testable from Hackage. Often
+ times, authors test their builds locally, but the tarball that gets uploaded
+ to Hackage is missing some necessary files. The best way to do this is to
+ set up a Travis job to do it for you. We recommend the
+ [multi-ghc-travis](https://github.com/hvr/multi-ghc-travis) approach.
+* Make your code compatible with the newest versions of all dependencies.
+* Make your code compatible with the versions of libraries that ship with GHC ([more information on lenient lower bounds](https://www.fpcomplete.com/blog/2014/05/lenient-lower-bounds)).
+
+There are certainly many other tips that could be added here. If you think of
+any, please send a pull request!
+
Build the package set
---------------------
@@ -49,6 +78,28 @@ build by running:
cabal install stackage
stackage nightly
+### Docker
+
+Note: This method has been disabled for now, but may be enabled again in the future.
+
+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
@@ -68,45 +119,3 @@ The following describes at a high level the series of steps for processing
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.)
diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs
deleted file mode 100644
index 94baca9e..00000000
--- a/Stackage/BuildConstraints.hs
+++ /dev/null
@@ -1,211 +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
- ) 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)
-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
- }
- 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
- ]
- 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"
- 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 man = do
- e <- isFile fp
- if e
- then decodeFileEither (fpToString fp) >>= either throwIO toBC
- else httpLbs req man >>=
- either throwIO toBC . decodeEither' . toStrict . responseBody
- where
- fp = "build-constraints.yaml"
- req = "https://raw.githubusercontent.com/fpco/stackage/master/build-constraints.yaml"
-
-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
- { cfGlobalFlags :: Map FlagName Bool
- , 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)
- }
-
-instance FromJSON ConstraintFile where
- parseJSON = withObject "ConstraintFile" $ \o -> do
- cfGlobalFlags <- goFlagMap <$> o .: "global-flags"
- 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"
- 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
- 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) ++
- cfGlobalFlags
-
- bcGithubUsers = cfGithubUsers
diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs
deleted file mode 100644
index 27868f06..00000000
--- a/Stackage/BuildPlan.hs
+++ /dev/null
@@ -1,207 +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
- ) 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 {..}
-
-newBuildPlan :: MonadIO m => BuildConstraints -> m BuildPlan
-newBuildPlan bc@BuildConstraints {..} = liftIO $ do
- packagesOrig <- getLatestDescriptions (isAllowed bc) (mkPackagePlan bc)
- 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
diff --git a/Stackage/CheckBuildPlan.hs b/Stackage/CheckBuildPlan.hs
deleted file mode 100644
index 1ad76b27..00000000
--- a/Stackage/CheckBuildPlan.hs
+++ /dev/null
@@ -1,111 +0,0 @@
-{-# 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
- ) where
-
-import Control.Monad.Writer.Strict (Writer, execWriter, tell)
-import qualified Data.Text as T
-import Stackage.BuildConstraints
-import Stackage.BuildPlan
-import Stackage.PackageDescription
-import Stackage.Prelude
-
--- FIXME check cycles in dependencies, only looking at libraries and
--- executables
-
-checkBuildPlan :: MonadThrow m => BuildPlan -> m ()
-checkBuildPlan BuildPlan {..}
- | null errs' = return ()
- | otherwise = throwM errs
- where
- allPackages = siCorePackages bpSystemInfo ++ map ppVersion bpPackages
- errs@(BadBuildPlan errs') =
- execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages
-
-checkDeps :: Map PackageName Version
- -> (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
- | version `withinRange` range -> return ()
- | 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
- }
-
-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
index c1b087ac..00000000
--- a/Stackage/CompleteBuild.hs
+++ /dev/null
@@ -1,214 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-module Stackage.CompleteBuild
- ( BuildType (..)
- , BumpType (..)
- , completeBuild
- , justCheck
- ) where
-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.IO (BufferMode (LineBuffering), hSetBuffering)
-
-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 ()
- }
-
-getSettings :: Manager -> BuildType -> IO Settings
-getSettings man Nightly = do
- day <- tshow . utctDay <$> getCurrentTime
- let slug' = "nightly-" ++ day
- plan' <- defaultBuildConstraints man >>= newBuildPlan
- return Settings
- { planFile = fpFromText ("nightly-" ++ day) <.> "yaml"
- , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day
- , 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 ()
- }
-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
- plan' <- defaultBuildConstraints man >>= newBuildPlan
- 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
- plan' <- updateBuildPlan oldplan
- return (new, plan')
-
- let newfile = renderLTSVer new
-
- return Settings
- { planFile = newfile
- , buildDir = fpFromText $ "builds/stackage-lts-" ++ tshow new
- , 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"]
- }
-
-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"
- ]
-
--- | Generate and check a new build plan, but do not execute it.
---
--- Since 0.3.1
-justCheck :: IO ()
-justCheck = withManager tlsManagerSettings $ \man -> do
- putStrLn "Loading build constraints"
- bc <- defaultBuildConstraints man
-
- putStrLn "Creating build plan"
- plan <- newBuildPlan bc
-
- putStrLn $ "Writing build plan to check-plan.yaml"
- encodeFile "check-plan.yaml" plan
-
- putStrLn "Checking plan"
- checkBuildPlan plan
-
- putStrLn "Plan seems valid!"
-
-completeBuild :: BuildType -> IO ()
-completeBuild buildType = withManager tlsManagerSettings $ \man -> do
- hSetBuffering stdout LineBuffering
-
- putStrLn $ "Loading settings for: " ++ tshow buildType
- Settings {..} <- getSettings man buildType
-
- putStrLn $ "Writing build plan to: " ++ fpToText planFile
- encodeFile (fpToString planFile) plan
-
- putStrLn "Checking build plan"
- checkBuildPlan plan
-
- putStrLn "Performing build"
- let pb = PerformBuild
- { pbPlan = plan
- , pbInstallDest = buildDir
- , pbLogDir = logDir
- , pbLog = hPut stdout
- , pbJobs = 8
- , pbGlobalInstall = False
- }
- performBuild pb >>= mapM_ putStrLn
-
- putStrLn "Uploading bundle to Stackage Server"
- token <- readFile "/auth-token"
- now <- epochTime
- let ghcVer = display $ siGhcVersion $ bpSystemInfo plan
- (ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def
- { ubContents = serverBundle now (title ghcVer) slug plan
- , ubAuthToken = decodeUtf8 token
- }
- putStrLn $ "New ident: " ++ unSnapshotIdent ident
- forM_ mloc $ \loc ->
- putStrLn $ "Track progress at: " ++ loc
-
- postBuild `catchAny` print
-
- putStrLn "Uploading docs to Stackage Server"
- res1 <- uploadDocs UploadDocs
- { udServer = def
- , udAuthToken = decodeUtf8 token
- , udDocs = pbDocDir pb
- , udSnapshot = ident
- } man
- putStrLn $ "Doc upload response: " ++ tshow res1
-
- ecreds <- tryIO $ readFile "/hackage-creds"
- case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of
- [username, password] -> do
- putStrLn "Uploading as Hackage distro"
- res2 <- uploadHackageDistro plan username password man
- putStrLn $ "Distro upload response: " ++ tshow res2
- _ -> putStrLn "No creds found, skipping Hackage distro upload"
-
- putStrLn "Uploading doc map"
- uploadDocMap UploadDocMap
- { udmServer = def
- , udmAuthToken = decodeUtf8 token
- , udmSnapshot = ident
- , udmDocDir = pbDocDir pb
- , udmPlan = plan
- } man >>= print
diff --git a/Stackage/CorePackages.hs b/Stackage/CorePackages.hs
deleted file mode 100644
index 896ff002..00000000
--- 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/GithubPings.hs b/Stackage/GithubPings.hs
deleted file mode 100644
index bb7369f4..00000000
--- 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/PackageDescription.hs b/Stackage/PackageDescription.hs
deleted file mode 100644
index 24263701..00000000
--- 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
index 6b4c8087..00000000
--- 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
index 31602d55..00000000
--- a/Stackage/PerformBuild.hs
+++ /dev/null
@@ -1,433 +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)
-import Filesystem.Path (parent)
-import qualified Filesystem.Path as F
-import Stackage.BuildConstraints
-import Stackage.BuildPlan
-import Stackage.PackageDescription
-import Stackage.Prelude hiding (pi)
-import System.Directory (findExecutable)
-import System.Environment (getEnvironment)
-import System.IO (IOMode (WriteMode),
- withBinaryFile)
-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
- }
-
-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 ()
- | otherwise -> throwSTM $ ToolMissing exe
- 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"
-
-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)
- mapM_ removeTree' [pbInstallDest, pbLogDir]
-
- forM_ (pbDatabase pb) $ \db -> 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
-
- forM_ packageMap $ \pi -> void $ async $ singleBuild pb 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)
- (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)
-
- -- | Separate for the PATH environment variable
- pathSep :: Char
-#ifdef mingw32_HOST_OS
- pathSep = ';'
-#else
- pathSep = ':'
-#endif
-
-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 -> SingleBuild -> IO ()
-singleBuild pb@PerformBuild {..} 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
- wfd libComps buildLibrary
-
- wfd testComps runTests
-
- name = display $ piName sbPackageInfo
- namever = concat
- [ name
- , "-"
- , display $ ppVersion $ piPlan sbPackageInfo
- ]
-
- runIn wdir outH cmd args =
- withCheckedProcess cp $ \ClosedStream UseProvidedHandle UseProvidedHandle ->
- (return () :: IO ())
- where
- cp = (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
- createTree $ parent fp
- withBinaryFile (fpToString fp) WriteMode inner'
-
- configArgs = ($ []) $ execWriter $ do
- 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
- 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 $ \outH -> do
- let run = runChild outH
- log' $ "Unpacking " ++ namever
- runParent outH "cabal" ["unpack", namever]
-
- log' $ "Configuring " ++ namever
- run "cabal" $ "configure" : configArgs
-
- log' $ "Building " ++ namever
- run "cabal" ["build"]
-
- log' $ "Copying/registering " ++ namever
- run "cabal" ["copy"]
- withMVar sbRegisterMutex $ const $
- run "cabal" ["register"]
-
- -- 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
-
- when (pcHaddocks /= Don'tBuild && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)) $ 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
-
- case (eres, pcHaddocks) of
- (Left e, ExpectSuccess) -> throwM e
- (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
- _ -> return ()
-
- runTests = wf testOut $ \outH -> do
- let run = runChild outH
-
- when (pcTests /= Don'tBuild) $ 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]
-
- 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
-
-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) ())
-
-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
diff --git a/Stackage/Prelude.hs b/Stackage/Prelude.hs
deleted file mode 100644
index ab2187fc..00000000
--- a/Stackage/Prelude.hs
+++ /dev/null
@@ -1,103 +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
-
-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)
diff --git a/Stackage/ServerBundle.hs b/Stackage/ServerBundle.hs
deleted file mode 100644
index 6cdf5cb4..00000000
--- a/Stackage/ServerBundle.hs
+++ /dev/null
@@ -1,114 +0,0 @@
--- | Create a bundle to be uploaded to Stackage Server.
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-module Stackage.ServerBundle
- ( serverBundle
- , epochTime
- , bpAllPackages
- , docsListing
- ) 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 qualified Data.Yaml as Y
-import Filesystem (isFile)
-import Foreign.C.Types (CTime (CTime))
-import Stackage.BuildConstraints
-import Stackage.BuildPlan
-import Stackage.Prelude
-import qualified System.PosixCompat.Time as PC
-import qualified Text.XML as X
-import Text.XML.Cursor
-
--- | 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)
-
-docsListing :: BuildPlan
- -> FilePath -- ^ docs directory
- -> IO ByteString
-docsListing bp docsDir =
- fmap (Y.encode . fold) $ mapM go $ mapToList $ bpAllPackages bp
- where
- go :: (PackageName, Version) -> IO (Map Text Y.Value)
- 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) $ Y.object
- [ "version" Y..= display version
- , "modules" Y..= m
- ]
- else return mempty
diff --git a/Stackage/UpdateBuildPlan.hs b/Stackage/UpdateBuildPlan.hs
deleted file mode 100644
index 617560b5..00000000
--- a/Stackage/UpdateBuildPlan.hs
+++ /dev/null
@@ -1,52 +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 :: BuildPlan -> IO BuildPlan
-updateBuildPlan = newBuildPlan . 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
- }
- 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
index bb1c8246..00000000
--- a/Stackage/Upload.hs
+++ /dev/null
@@ -1,265 +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
- , UploadDocMap (..)
- , uploadDocMap
- ) where
-
-import Control.Monad.Writer.Strict (execWriter, tell)
-import Data.Default.Class (Default (..))
-import Filesystem (isDirectory, isFile)
-import Network.HTTP.Client
-import Network.HTTP.Client.MultipartFormData
-import Stackage.BuildPlan (BuildPlan)
-import Stackage.Prelude
-import Stackage.ServerBundle (bpAllPackages, docsListing)
-import System.IO.Temp (withSystemTempFile)
-
-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 <- fmap sort
- $ runResourceT
- $ sourceDirectory fp0
- $$ filterMC (liftIO . isDirectory)
- =$ mapC (fpToString . filename)
- =$ sinkList
- writeFile (fp0 "index.html") $ mkIndex
- (unpack $ unSnapshotIdent ident)
- dirs
- writeFile (fp0 "style.css") styleCss
- -- FIXME write index.html, style.css
- 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 bp username password =
- httpLbs (applyBasicAuth username password req)
- 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) ++
- "\""
-
- req = "http://hackage.haskell.org/distro/Stackage/packages.csv"
- { requestHeaders = [("Content-Type", "text/csv")]
- , requestBody = RequestBodyLBS csv
- , checkStatus = \_ _ _ -> Nothing
- , method = "PUT"
- }
-
-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 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
- ]
-
-mkIndex :: String -> [String] -> String
-mkIndex snapid dirs = concat
- [ "\nHaddocks index"
- , ""
- , ""
- , ""
- , ""
- , ""
- , "
"
- , "
Haddock documentation index
"
- , "
Return to snapshot
"
- , concatMap toLI dirs
- , "