diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,5 @@
+## 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/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,20 @@
+Copyright (c) 2012 FP Complete, http://www.fpcomplete.com/
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+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 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.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,112 @@
+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
+
+## 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.)
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs
new file mode 100644
--- /dev/null
+++ b/Stackage/BuildConstraints.hs
@@ -0,0 +1,214 @@
+{-# 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 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
+
+loadBuildConstraints fp = decodeFileEither fp >>= either throwIO toBC
+
+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
new file mode 100644
--- /dev/null
+++ b/Stackage/BuildPlan.hs
@@ -0,0 +1,207 @@
+{-# 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
new file mode 100644
--- /dev/null
+++ b/Stackage/CheckBuildPlan.hs
@@ -0,0 +1,108 @@
+{-# 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 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
+ , " ("
+ , 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
new file mode 100644
--- /dev/null
+++ b/Stackage/CompleteBuild.hs
@@ -0,0 +1,190 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Stackage.CompleteBuild
+ ( BuildType (..)
+ , BumpType (..)
+ , completeBuild
+ ) 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 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"
+ ]
+
+completeBuild :: BuildType -> IO ()
+completeBuild buildType = withManager defaultManagerSettings $ \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
+ }
+ performBuild pb >>= mapM_ putStrLn
+
+ putStrLn "Uploading bundle to Stackage Server"
+ token <- readFile "/auth-token"
+ now <- epochTime
+ let ghcVer = display $ siGhcVersion $ bpSystemInfo plan
+ ident <- flip uploadBundle man $ setArgs ghcVer def
+ { ubContents = serverBundle now (title ghcVer) slug plan
+ , ubAuthToken = decodeUtf8 token
+ }
+ putStrLn $ "New ident: " ++ unSnapshotIdent ident
+
+ 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
+
+ postBuild
diff --git a/Stackage/CorePackages.hs b/Stackage/CorePackages.hs
new file mode 100644
--- /dev/null
+++ b/Stackage/CorePackages.hs
@@ -0,0 +1,53 @@
+{-# 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
new file mode 100644
--- /dev/null
+++ b/Stackage/GithubPings.hs
@@ -0,0 +1,36 @@
+{-# 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
new file mode 100644
--- /dev/null
+++ b/Stackage/PackageDescription.hs
@@ -0,0 +1,200 @@
+{-# 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
new file mode 100644
--- /dev/null
+++ b/Stackage/PackageIndex.hs
@@ -0,0 +1,127 @@
+{-# 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 (== '/') 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
new file mode 100644
--- /dev/null
+++ b/Stackage/PerformBuild.hs
@@ -0,0 +1,398 @@
+-- | Perform an actual build, generate a binary package database and a
+-- documentation directory in the process.
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Stackage.PerformBuild
+ ( performBuild
+ , PerformBuild (..)
+ , BuildException (..)
+ , pbDocDir
+ ) where
+
+import Stackage.BuildConstraints
+import Stackage.PackageDescription
+import Stackage.BuildPlan
+import Stackage.Prelude hiding (pi)
+import qualified Data.Map as Map
+import Control.Concurrent.STM.TSem
+import Data.NonNull (fromNullable)
+import Control.Concurrent.Async (async)
+import System.IO.Temp (withSystemTempDirectory)
+import Filesystem (createTree, removeTree, isDirectory, rename, canonicalizePath, getWorkingDirectory)
+import System.IO (withBinaryFile, IOMode (WriteMode))
+import Filesystem.Path (parent)
+import qualified Filesystem.Path as F
+import System.Environment (getEnvironment)
+import System.Directory (findExecutable)
+
+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
+ }
+
+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 counter = bracket_
+ (atomically $ modifyTVar counter (+ 1))
+ (atomically $ modifyTVar counter (subtract 1))
+
+withTSem sem = bracket_ (atomically $ waitTSem sem) (atomically $ signalTSem sem)
+
+pbDatabase pb = pbInstallDest pb "pkgdb"
+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
+ let removeTree' fp = whenM (isDirectory fp) (removeTree fp)
+ mapM_ removeTree' [pbInstallDest, pbLogDir]
+
+ createTree $ parent $ pbDatabase pb
+ withCheckedProcess (proc "ghc-pkg" ["init", fpToString (pbDatabase pb)])
+ $ \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 = ("HASKELL_PACKAGE_SANDBOX", fpToString $ 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 =
+ [ "--package-db=clear"
+ , "--package-db=global"
+ , "--package-db=" ++ fpToText (pbDatabase pb)
+ , "--libdir=" ++ fpToText (pbLibDir pb)
+ , "--bindir=" ++ fpToText (pbBinDir pb)
+ , "--datadir=" ++ fpToText (pbDataDir pb)
+ , "--docdir=" ++ fpToText (pbDocDir pb)
+ , "--flags=" ++ flags
+ ]
+
+ 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
new file mode 100644
--- /dev/null
+++ b/Stackage/Prelude.hs
@@ -0,0 +1,104 @@
+{-# 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 System.Exit (ExitCode (ExitSuccess))
+
+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
new file mode 100644
--- /dev/null
+++ b/Stackage/ServerBundle.hs
@@ -0,0 +1,107 @@
+-- | 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.Yaml as Y
+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
+import Filesystem (isFile)
+
+-- | Get current time
+epochTime :: IO Tar.EpochTime
+epochTime = (\(CTime t) -> 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)
+ ]
+ 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")
+
+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
new file mode 100644
--- /dev/null
+++ b/Stackage/UpdateBuildPlan.hs
@@ -0,0 +1,52 @@
+{-# 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
new file mode 100644
--- /dev/null
+++ b/Stackage/Upload.hs
@@ -0,0 +1,260 @@
+-- | 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
+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
+ 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 (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 {..} 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
+ , "