stackage (empty) → 0.1.0.0
raw patch · 24 files changed
+3317/−0 lines, 24 filesdep +Cabaldep +QuickCheckdep +aesonsetup-changed
Dependencies added: Cabal, QuickCheck, aeson, async, base, bytestring, classy-prelude-conduit, conduit-extra, containers, data-default-class, directory, filepath, hspec, http-client, mono-traversable, mtl, old-locale, process, semigroups, stackage, stm, streaming-commons, system-fileio, system-filepath, tar, temporary, text, time, transformers, unix-compat, utf8-string, xml-conduit, yaml, zlib
Files
- ChangeLog.md +5/−0
- LICENSE +20/−0
- README.md +112/−0
- Setup.hs +2/−0
- Stackage/BuildConstraints.hs +214/−0
- Stackage/BuildPlan.hs +207/−0
- Stackage/CheckBuildPlan.hs +108/−0
- Stackage/CompleteBuild.hs +190/−0
- Stackage/CorePackages.hs +53/−0
- Stackage/GithubPings.hs +36/−0
- Stackage/PackageDescription.hs +200/−0
- Stackage/PackageIndex.hs +127/−0
- Stackage/PerformBuild.hs +398/−0
- Stackage/Prelude.hs +104/−0
- Stackage/ServerBundle.hs +107/−0
- Stackage/UpdateBuildPlan.hs +52/−0
- Stackage/Upload.hs +260/−0
- app/stackage.hs +15/−0
- build-constraints.yaml +937/−0
- stackage.cabal +93/−0
- test/Spec.hs +1/−0
- test/Stackage/BuildPlanSpec.hs +36/−0
- test/Stackage/CorePackagesSpec.hs +19/−0
- test/Stackage/PackageIndexSpec.hs +21/−0
+ ChangeLog.md view
@@ -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.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Stackage/BuildConstraints.hs view
@@ -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
+ Stackage/BuildPlan.hs view
@@ -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
+ Stackage/CheckBuildPlan.hs view
@@ -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
+ Stackage/CompleteBuild.hs view
@@ -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
+ Stackage/CorePackages.hs view
@@ -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
+ Stackage/GithubPings.hs view
@@ -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+ _ -> []
+ Stackage/PackageDescription.hs view
@@ -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+ }
+ Stackage/PackageIndex.hs view
@@ -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
+ Stackage/PerformBuild.hs view
@@ -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
+ Stackage/Prelude.hs view
@@ -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)
+ Stackage/ServerBundle.hs view
@@ -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
+ Stackage/UpdateBuildPlan.hs view
@@ -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] []
+ Stackage/Upload.hs view
@@ -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+ [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"+ , "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>"+ , "<link rel='stylesheet' href='style.css'>"+ , "<link rel='shortcut icon' href='http://www.stackage.org/static/img/favicon.ico' />"+ , "</head>"+ , "<body><div class='container'>"+ , "<div class='row'><div class='span12 col-md-12'>"+ , "<h1>Haddock documentation index</h1>"+ , "<p class='return'><a href=\"http://www.stackage.org/stackage/"+ , snapid+ , "\">Return to snapshot</a></p><ul>"+ , concatMap toLI dirs+ , "</ul></div></div></div></body></html>"+ ]+ where+ toLI name = concat+ [ "<li><a href='"+ , name+ , "/index.html'>"+ , name+ , "</a></li>"+ ]++styleCss :: String+styleCss = concat+ [ "@media (min-width: 530px) {"+ , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"+ , "}"+ , "@media (min-width: 760px) {"+ , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"+ , "}"+ , "ul {"+ , " margin-left: 0;"+ , " padding-left: 0;"+ , " list-style-type: none;"+ , "}"+ , "body {"+ , " background: #f0f0f0;"+ , " font-family: 'Lato', sans-serif;"+ , " text-shadow: 1px 1px 1px #ffffff;"+ , " font-size: 20px;"+ , " line-height: 30px;"+ , " padding-bottom: 5em;"+ , "}"+ , "h1 {"+ , " font-weight: normal;"+ , " color: #06537d;"+ , " font-size: 45px;"+ , "}"+ , ".return a {"+ , " color: #06537d;"+ , " font-style: italic;"+ , "}"+ , ".return {"+ , " margin-bottom: 1em;"+ , "}"]
+ app/stackage.hs view
@@ -0,0 +1,15 @@+import Stackage.CompleteBuild+import System.Environment (getArgs)++main :: IO ()+main = do+ args <- getArgs+ case args of+ [x] | Just y <- lookup x m -> completeBuild y+ _ -> error $ "Expected one argument, one of: " ++ unwords (map fst m)+ where+ m =+ [ ("nightly", Nightly)+ , ("lts-major", LTS Major)+ , ("lts-minor", LTS Minor)+ ]
+ build-constraints.yaml view
@@ -0,0 +1,937 @@+# Constraints for brand new builds+packages:+ "Stackage upper bounds":+ # cabal-install is buggy still.+ - network < 2.6+ - network-uri < 2.6++ # https://github.com/fpco/stackage/issues/288+ - text < 1.2++ # Force a specific version that's compatible with transformers 0.3+ - transformers-compat == 0.3.3.3++ # https://github.com/fpco/stackage/issues/291+ - random < 1.0.1.3++ # https://github.com/fpco/stackage/issues/314+ - hxt < 9.3.1.9++ # https://github.com/fpco/stackage/issues/318+ - HaXml < 1.25++ # https://github.com/fpco/stackage/issues/319+ - polyparse < 1.10++ # https://github.com/nikita-volkov/stm-containers/issues/3+ - free < 4.10++ "Michael Snoyman michael@snoyman.com @snoyberg":+ - bzlib-conduit+ - cabal-install < 1.19+ - cabal-src+ - case-insensitive+ - classy-prelude-yesod+ - conduit-combinators+ - conduit-extra+ - hebrew-time+ - keter+ - markdown+ - mime-mail-ses+ - monadcryptorandom+ - network-conduit-tls+ - persistent+ - persistent-mysql+ - persistent-postgresql+ - persistent-sqlite+ - persistent-template+ - process-conduit+ - random-shuffle+ - sphinx+ - stm-conduit+ - wai-websockets+ - warp-tls+ - yackage+ - yesod+ - yesod-auth-deskcom+ - yesod-bin+ - yesod-eventsource+ - yesod-fay+ - yesod-gitrepo+ - yesod-newsfeed+ - yesod-sitemap+ - yesod-static+ - yesod-test+ - yesod-websockets+ - repa+ - repa-io+ - repa-algorithms+ - repa-devil+ - JuicyPixels-repa++ "FP Complete michael@fpcomplete.com @snoyberg":+ - alex+ - async+ - aws+ - base16-bytestring+ - c2hs+ - cairo+ - cassava+ - Chart+ - Chart-diagrams+ - compdata+ - configurator+ - convertible+ - csv-conduit+ - diagrams-cairo+ - dimensional+ - executable-path+ - fgl+ - fixed-list+ - foreign-store+ - formatting+ - fpco-api+ - gtk2hs-buildtools+ - happy+ - histogram-fill+ - hmatrix+ - hmatrix-gsl+ - hxt+ - hxt-relaxng+ - hybrid-vectors+ - indents+ - language-c+ - lhs2tex+ - persistent-mongoDB+ - pretty-class+ - quandl-api+ - random-fu+ - random-source+ - shelly+ - smtLib+ - statistics-linreg+ - th-expand-syns+ - thyme+ - webdriver+ - web-fpco+ - criterion+ - th-lift+ - singletons+ - th-desugar+ - quickcheck-assertions+ - distributed-process+ - distributed-process-simplelocalnet+ # - cloud-haskell+ - kure <= 2.4.10++ "Omari Norman <omari@smileystation.com>":+ - barecheck+ - rainbow+ - rainbow-tests+ - quickpull++ "Neil Mitchell":+ - hlint+ - hoogle+ - shake+ - derive+ - tagsoup+ - cmdargs+ - safe+ - uniplate+ - nsis+ - js-jquery+ - js-flot+ - extra+ - bake+ - ghcid++ "Alan Zimmerman":+ - hjsmin+ - language-javascript++ "Alfredo Di Napoli <alfredo.dinapoli@gmail.com>":+ - mandrill++ "Jasper Van der Jeugt":+ - blaze-html+ - blaze-markup+ - stylish-haskell++ "Antoine Latter":+ - byteorder+ - uuid++ "Philipp Middendorf <pmidden@secure.mailbox.org>":+ - clock++ "Stefan Wehr <wehr@factisresearch.com>":+ - HTF+ - xmlgen+ - stm-stats++ "Bart Massey <bart.massey+stackage@gmail.com>":+ - parseargs++ "Vincent Hanquez":+ - bytedump+ - certificate+ - cipher-aes+ - cipher-rc4+ - connection+ - cprng-aes+ - cpu+ - cryptocipher+ - cryptohash+ - crypto-pubkey-types+ - crypto-random-api+ - hit+ - language-java+ - language-java+ - libgit+ - pem+ - siphash+ - socks+ - tls+ - tls-debug+ - vhd+ - udbus+ - xenstore++ "Chris Done":+ - ace+ - check-email+ - freenect+ - frisby+ - gd+ - hostname-validate+ - ini+ - lucid+ - osdkeys+ - pdfinfo+ - present+ - pure-io+ - scrobble+ - shell-conduit+ - sourcemap+ # requires old haddock currently - haskell-docs+ # TODO: Add hindent and structured-haskell-mode once they've been ported to HSE 1.16.++ # GHC 7.6+ # "Alberto G. Corona <agocorona@gmail.com>":+ # - RefSerialize+ # - TCache+ # - Workflow+ # - MFlow++ "Edward Kmett <ekmett@gmail.com>":+ - ad+ - adjunctions+ - approximate+ - bifunctors+ - bits+ - bound+ - bytes+ - charset+ - comonad+ - comonads-fd+ - comonad-transformers+ - compensated+ - compressed+ - concurrent-supply+ - constraints+ - contravariant+ - distributive+ - either+ - eq+ - ersatz+ - exceptions+ - free+ - graphs+ - groupoids+ - heaps+ - hyphenation+ - integration+ - intervals+ - kan-extensions+ - lca+ - lens+ - linear+ - linear-accelerate+ - log-domain+ - machines+ - monadic-arrays+ - monad-products+ - monad-products+ - monad-st+ - monad-st+ - mtl < 2.2+ - nats+ - numeric-extras+ - parsers+ - pointed+ - prelude-extras+ - profunctor-extras+ - profunctors+ - reducers+ - reducers+ - reflection+ - semigroupoid-extras+ - semigroupoids+ - semigroups+ - speculation+ - streams+ - tagged+ - vector-instances+ - void+ - wl-pprint-extras+ - wl-pprint-terminfo+ - fixed+ - half+ - gl+ - lens-aeson+ - zlib-lens+ # Temporary upper bound for some of the above packages+ - generic-deriving < 1.7+ # hyperloglog++ "Andrew Farmer <afarmer@ittc.ku.edu>":+ - scotty+ - wai-middleware-static++ "Simon Hengel <sol@typeful.net>":+ - hspec+ - hspec-wai+ - hspec-wai-json+ - aeson-qq+ - interpolate+ - doctest+ - base-compat++ "Mario Blazevic <blamario@yahoo.com>":+ - monad-parallel+ - monad-coroutine+ - incremental-parser+ - monoid-subclasses++ "Brent Yorgey <byorgey@gmail.com>":+ - active+ - BlogLiterately+ - BlogLiterately-diagrams+ - diagrams+ - diagrams-builder+ - diagrams-contrib+ - diagrams-core+ - diagrams-haddock+ - diagrams-lib+ - diagrams-postscript+ - diagrams-svg+ - dual-tree+ - force-layout+ - haxr+ - MonadRandom+ - monoid-extras+ - vector-space-points++ "Vincent Berthoux <vincent.berthoux@gmail.com>":+ # https://github.com/fpco/stackage/issues/354+ - JuicyPixels < 3.2++ "Patrick Brisbin":+ - gravatar++ # https://github.com/fpco/stackage/issues/299+ # mapM_ (add "Paul Harper <benekastah@gmail.com>") $ words "yesod-auth-oauth2"++ "Felipe Lessa <felipe.lessa@gmail.com>":+ - esqueleto+ - fb+ - fb-persistent+ - yesod-fb+ - yesod-auth-fb++ "Alexander Altman <alexanderaltman@me.com>":+ - base-unicode-symbols+ - containers-unicode-symbols++ "Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>":+ - accelerate++ "Dan Burton <danburton.email@gmail.com>":+ - basic-prelude+ - composition+ - io-memoize+ - numbers+ - rev-state+ - runmemo+ - tardis+ - lens-family-th++ "Daniel Díaz <dhelta.diaz@gmail.com>":+ - HaTeX+ - matrix+ - binary-list++ "Gabriel Gonzalez <Gabriel439@gmail.com>":+ - pipes+ - pipes-parse+ - pipes-concurrency++ "Chris Allen <cma@bitemyapp.com>":+ - bloodhound++ "Adam Bergmark <adam@bergmark.nl>":+ - fay+ - fay-base+ - fay-dom+ - fay-jquery+ - fay-text+ - fay-uri+ - snaplet-fay++ "Rodrigo Setti <rodrigosetti@gmail.com>":+ - messagepack+ - messagepack-rpc++ "Boris Lykah <lykahb@gmail.com>":+ - groundhog+ - groundhog-th+ - groundhog-sqlite+ - groundhog-postgresql+ - groundhog-mysql++ "Janne Hellsten <jjhellst@gmail.com>":+ - sqlite-simple++ "Michal J. Gajda":+ - iterable+ - Octree+ - FenwickTree+ - hPDB+ - hPDB-examples++ "Roman Cheplyaka <roma@ro-che.info>":+ - action-permutations+ - amqp+ - curl+ - generics-sop++ # https://github.com/fpco/stackage/issues/341+ - haskell-names < 0.5++ - haskell-packages+ - heredoc+ - hse-cpp+ - immortal+ - regex-applicative+ - smallcheck+ - tasty+ - tasty-golden+ - tasty-hunit+ - tasty-quickcheck+ - tasty-smallcheck+ - time-lens+ - timezone-olson+ - timezone-series+ - traverse-with-class++ "George Giorgidze <giorgidze@gmail.com>":+ - HCodecs+ - YampaSynth++ "Phil Hargett <phil@haphazardhouse.net>":+ - courier++ "Aycan iRiCAN <iricanaycan@gmail.com>":+ - hdaemonize+ - hsyslog+ - hweblib++ "Joachim Breitner <mail@joachim-breitner.de>":+ - circle-packing+ - arbtt+ - ghc-heap-view++ "Aditya Bhargava <adit@adit.io":+ - HandsomeSoup++ "Clint Adams <clint@debian.org>":+ - hOpenPGP+ - openpgp-asciiarmor+ - MusicBrainz+ - DAV+ - hopenpgp-tools++ # https://github.com/fpco/stackage/issues/160+ "Ketil Malde":+ - biocore+ - biofasta+ - biofastq+ - biosff+ - blastxml+ - bioace+ - biophd < 0.0.6 || > 0.0.6+ - biopsl # https://github.com/ingolia/SamTools/issues/3 samtools+ - seqloc+ - bioalign+ - BlastHTTP+ # The following have out-of-date dependencies currently+ # biostockholm memexml RNAwolf+ # , "Biobase BiobaseDotP BiobaseFR3D BiobaseInfernal BiobaseMAF"+ # , "BiobaseTrainingData BiobaseTurner BiobaseXNA BiobaseVienna"+ # , "BiobaseTypes BiobaseFasta"+ # MC-Fold-DP++ "Silk <code@silk.co>":+ - aeson-utils+ - arrow-list+ - attoparsec-expr+ - bumper+ - code-builder+ - fay-builder+ - generic-aeson+ - hxt-pickle-utils+ - imagesize-conduit+ - imagesize-conduit+ - json-schema+ - multipart+ - regular-xmlpickler+ - rest-client+ - rest-core+ - rest-gen+ - rest-happstack+ - rest-snap+ - rest-stringmap+ - rest-types+ - rest-wai+ - tostring+ - tostring+ - uri-encode+ - uri-encode++ "Simon Michael <simon@joyful.com>":+ - hledger++ "Mihai Maruseac <mihai.maruseac@gmail.com>":+ - io-manager++ "Dimitri Sabadie <dimitri.sabadie@gmail.com":+ - monad-journal++ "Thomas Schilling <nominolo@googlemail.com>":+ - ghc-syb-utils++ "Boris Buliga <d12frosted@icloud.com>":+ - ghc-mod+ - io-choice+ - system-canonicalpath++ "Yann Esposito <yann.esposito@gmail.com>":+ - holy-project++ "Paul Rouse <pgr@doynton.org>":+ - yesod-auth-hashdb++ "Toralf Wittner <tw@dtex.org>":+ - zeromq4-haskell++ "trupill@gmail.com":+ - djinn-lib+ - djinn-ghc++ "Arash Rouhani <miffoljud@gmail.com>":+ - yesod-text-markdown++ "Matvey Aksenov <matvey.aksenov@gmail.com":+ - terminal-size++ "Luis G. Torres <lgtorres42@gmail.com":+ - kdt++ "Emanuel Borsobom <manny@fpcomplete.com>":+ - BoundedChan+ - bytestring-lexing+ - bytestring-trie+ - data-accessor+ - data-accessor-mtl+ - file-location+ - fuzzcheck+ - git-embed+ - haddock-api+ - here+ - hlibgit2+ - hostname-validate+ - interpolatedstring-perl6+ - iproute+ - missing-foreign+ - MissingH+ - multimap+ - parallel-io+ - text-binary++ "Michael Sloan <mgsloan@gmail.com":+ - th-orphans+ - th-reify-many++ "Nikita Volkov <nikita.y.volkov@mail.ru>":+ - base-prelude+ - cases+ - focus+ - hasql+ - hasql-backend+ - hasql-postgres+ - list-t+ - mtl-prelude < 2+ - neat-interpolation+ - partial-handler+ - postgresql-binary+ - slave-thread+ - stm-containers++ "Iustin Pop <iustin@k1024.org>":+ - prefix-units++ "Alexander Thiemann <mail@athiemann.net>":+ - graph-core+ - reroute+ - Spock++ "Joey Eremondi <joey@eremondi.com>":+ - aeson-pretty+ - digest+ - elm-build-lib+ - elm-compiler+ - elm-core-sources+ # elm-package+ - language-glsl+ - prettyclass+ - QuasiText+ - union-find+ - zip-archive+++ "Arthur Fayzrakhmanov <heraldhoi@gmail.com>":+ - sodium+ - hdevtools++ # 0.16.2 fixes dependency issues with different version of GHC+ # and Haskell Platform. Now builds on GHC 7.4-7.8. Version 1.0 is+ # guaranteed to break the API. See+ # https://travis-ci.org/jswebtools/language-ecmascript for+ # current build status.+ "Andrey Chudnov <oss@chudnov.com>":+ - language-ecmascript >= 0.16.2 && < 1.0++ "Tom Ellis <tom-stackage@jaguarpaw.co.uk>":+ - opaleye+ - product-profunctors++# Global flags are applied to all packages+global-flags:+ blaze_html_0_5: true+ small_base: true+ https: true+ splitbase: true+ old-locale: true+ new-base: true+ bytestring-in-base: false+ test-hlint: false+ network-uri: false # network-uri: true++# Package flags are applied to individual packages, and override the values of+# global-flags+package-flags:+ mersenne-random-pure64:+ small_base: false++# By skipping a test suite, we do not pull in the build dependencies+skipped-tests:+ - ReadArgs # old version of hspec+ - ersatz # old QuickCheck+ - punycode # pulls in encoding+ - HTTP+ - Octree+ - options+ - hasql++ # require old hspec+ - bloodhound+ - fb++ # require old tasty+ - diagrams-haddock++ # requires old hsql+ - hasql-postgres++ # https://github.com/pa-ba/compdata/issues/4+ - compdata++ # https://github.com/fpco/stackage/issues/368+ - lifted-base++# Tests which we should build and run, but which are expected to fail. We+# should not fail a build based on a test failure for one of these packages.+expected-test-failures:+ # Requires an old version of WAI and Warp for tests+ - HTTP++ # text and setenv have recursive dependencies in their tests, which+ # cabal can't (yet) handle+ - text+ - setenv++ # The version of GLUT included with the HP does not generate+ # documentation correctly.+ - GLUT++ # https://github.com/bos/statistics/issues/42+ - statistics++ # https://github.com/kazu-yamamoto/simple-sendfile/pull/10+ - simple-sendfile++ # http://hackage.haskell.org/trac/hackage/ticket/954+ - diagrams++ # https://github.com/fpco/stackage/issues/24+ - unix-time++ # With transformers 0.3, it doesn't provide any modules+ - transformers-compat++ # Tests require shell script and are incompatible with sandboxed package+ # databases+ - HTF++ # https://github.com/simonmar/monad-par/issues/28+ - monad-par++ # Unfortunately network failures seem to happen haphazardly+ - network++ # https://github.com/ekmett/hyphenation/issues/1+ - hyphenation++ # Test suite takes too long to run on some systems+ - punycode++ # http://hub.darcs.net/stepcut/happstack/issue/1+ - happstack-server++ # Requires a Facebook app.+ - fb++ # https://github.com/tibbe/hashable/issues/64+ - hashable++ # https://github.com/vincenthz/language-java/issues/10+ - language-java++ - threads+ - crypto-conduit+ - pandoc+ - language-ecmascript+ - hspec+ - alex++ # https://github.com/basvandijk/concurrent-extra/issues/+ - concurrent-extra++ # https://github.com/skogsbaer/xmlgen/issues/2+ - xmlgen++ # Something very strange going on with the test suite, I can't figure+ # out how to fix it+ - bson++ # Requires a locally running PostgreSQL server with appropriate users+ - postgresql-simple++ # Missing files+ - websockets++ # Some kind of Cabal bug when trying to run tests+ - thyme++ - shake++ # https://github.com/jgm/pandoc-citeproc/issues/5+ - pandoc-citeproc++ # Problems with doctest and sandboxing+ - warp+ - wai-logger++ # https://github.com/fpco/stackage/issues/163+ - hTalos+ - seqloc++ # https://github.com/bos/math-functions/issues/25+ - math-functions++ # FIXME the test suite fails fairly regularly in builds, though I haven't+ # discovered why yet+ - crypto-numbers++ # Test suite is currently failing regularly, needs to be worked out still.+ - lens++ # Requires too old a version of test-framework+ - time++ # Cloud Haskell tests seem to be unreliable+ - distributed-process+ - lockfree-queue+ - network-transport-tcp++ # Pulls in monad-peel which does not compile+ - monad-control++ # https://github.com/fpco/stackage/issues/226+ - options++ # https://github.com/gtk2hs/gtk2hs/issues/36+ - glib+ - pango++ # https://github.com/acw/bytestring-progress/issues/3+ - bytestring-progress++ # Seems to require 32-bit functions+ - nettle++ # Depends on a missing graphviz executable+ - graphviz++ # No AWS creds available+ - aws++ # Not sure why...+ - singletons++ - hspec2+ - hspec-wai++ # https://github.com/fpco/stackage/issues/285+ - diagrams-haddock+ - scientific+ - json-schema++ # https://github.com/BioHaskell/octree/issues/4+ - Octree++ # No code until we upgrade to network 2.6+ - network-uri++ # https://github.com/goldfirere/th-desugar/issues/12+ - th-desugar++ # https://github.com/haskell/c2hs/issues/108+ - c2hs++ # https://github.com/jmillikin/haskell-filesystem/issues/3+ - system-filepath++ # Requires a running webdriver server+ - webdriver+ - webdriver-snoy++ # Weird conflicts with sandboxing+ - ghc-mod+ - ghcid++ # Requires locally running server+ - bloodhound++ # Too lazy to keep the test dependencies up to date+ - base-prelude+ - cases+ - focus+ - hasql+ - hasql-backend+ - hasql-postgres+ - list-t+ - mtl-prelude+ - neat-interpolation+ - partial-handler+ - postgresql-binary+ - slave-thread+ - stm-containers++ # https://github.com/gtk2hs/gtk2hs/issues/79+ - gio+ - gtk++ # Requires SAT solver and old QuickCheck+ - ersatz++ # https://github.com/ekmett/gl/issues/3+ - gl++ # Failing doctests+ - bits++ # No server running+ - amqp++ # Often run out of inotify handles+ - fsnotify++ # Requires a correctly set up Postgres instance+ - opaleye++ # weird problems with cabal test+ - cautious-file++# Haddocks which are expected to fail. Same concept as expected test failures.+expected-haddock-failures: []++# Benchmarks which should not be built. Note that Stackage does *not* generally+# build benchmarks. The difference here will be whether dependencies for these+# benchmarks are included or not.+skipped-benchmarks:+ - machines+ - criterion-plus+ - graphviz+ - lifted-base+ - pandoc+ - stm-containers+ - uuid++ # pulls in criterion-plus, which has restrictive upper bounds+ - cases+ - hasql-postgres++ # https://github.com/vincenthz/hs-crypto-cipher/issues/46+ - cipher-aes+ - cipher-blowfish+ - cipher-camellia+ - cipher-des+ - cipher-rc4++ # sometimes falls out-of-sync on hasql-postgres+ - hasql++# Mapping from Github account holding a package to the Github users who should+# be pinged on failure. If no value is specified here, then the owning account+# will be pinged.+github-users:+ diagrams:+ - byorgey+ - fryguybob+ - jeffreyrosenbluth+ - bergey+ yesodweb:+ - snoyberg+ fpco:+ - snoyberg+ faylang:+ - bergmark+ silkapp:+ - bergmark+ - hesselink+ snapframework:+ - mightybyte+ haskell-ro:+ - mihaimaruseac
+ stackage.cabal view
@@ -0,0 +1,93 @@+name: stackage+version: 0.1.0.0+synopsis: "Stable Hackage," tools for creating a vetted set of packages from Hackage.+description: Please see <http://www.stackage.org/package/stackage> for a description and documentation.+homepage: https://github.com/fpco/stackage+license: MIT+license-file: LICENSE+author: Michael Snoyman+maintainer: michael@fpcomplete.com+category: Distribution+build-type: Simple+cabal-version: >=1.10+extra-source-files: README.md+ ChangeLog.md+ build-constraints.yaml++library+ default-language: Haskell2010+ exposed-modules: Stackage.Prelude+ Stackage.BuildConstraints+ Stackage.CorePackages+ Stackage.PackageIndex+ Stackage.BuildPlan+ Stackage.CheckBuildPlan+ Stackage.UpdateBuildPlan+ Stackage.GithubPings+ Stackage.PackageDescription+ Stackage.ServerBundle+ Stackage.Upload+ Stackage.PerformBuild+ Stackage.CompleteBuild+ build-depends: base >= 4 && < 5+ , containers+ , Cabal >= 1.14+ , tar >= 0.3+ , zlib+ , bytestring+ , directory+ , filepath+ , transformers+ , process+ , old-locale+ , time < 1.5+ , utf8-string++ , conduit-extra+ , classy-prelude-conduit+ , text+ , system-fileio+ , system-filepath+ , mtl+ , aeson+ , yaml+ , unix-compat+ , http-client+ , temporary+ , data-default-class+ , stm+ , mono-traversable+ , async+ , streaming-commons >= 0.1.7.1+ , semigroups+ , xml-conduit++executable stackage+ default-language: Haskell2010+ hs-source-dirs: app+ main-is: stackage.hs+ build-depends: base+ , stackage+ ghc-options: -rtsopts -threaded -with-rtsopts=-N++test-suite spec+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Stackage.CorePackagesSpec+ Stackage.PackageIndexSpec+ Stackage.BuildPlanSpec+ build-depends: base+ , stackage+ , hspec+ , QuickCheck+ , text+ , classy-prelude-conduit+ , Cabal+ , yaml+ , containers++source-repository head+ type: git+ location: https://github.com/fpco/stackage
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Stackage/BuildPlanSpec.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}+module Stackage.BuildPlanSpec (spec) where++import Stackage.BuildPlan+import Stackage.Prelude+import Stackage.BuildConstraints+import Stackage.UpdateBuildPlan+import Test.Hspec+import qualified Data.Yaml as Y+import Distribution.Version (anyVersion)+import qualified Data.Map as Map++spec :: Spec+spec = it "works" $ do+ bc <- defaultBuildConstraints (error "manager should not be used")+ bp <- newBuildPlan bc+ let bs = Y.encode bp+ ebp' = Y.decodeEither bs++ bp' <- either error return ebp'++ let allPackages = Map.keysSet (bpPackages bp) ++ Map.keysSet (bpPackages bp')+ forM_ allPackages $ \name ->+ (name, lookup name (bpPackages bp')) `shouldBe`+ (name, lookup name (bpPackages bp))++ bpGithubUsers bp' `shouldBe` bpGithubUsers bp+ when (bp' /= bp) $ error "bp' /= bp"+ bp2 <- updateBuildPlan bp+ when (dropVersionRanges bp2 /= dropVersionRanges bp) $ error "bp2 /= bp"+ where+ dropVersionRanges bp =+ bp { bpPackages = map go $ bpPackages bp }+ where+ go pb = pb { ppConstraints = go' $ ppConstraints pb }+ go' pc = pc { pcVersionRange = anyVersion }
+ test/Stackage/CorePackagesSpec.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}+module Stackage.CorePackagesSpec (spec) where++import Stackage.CorePackages+import Stackage.Prelude+import Test.Hspec++spec :: Spec+spec = do+ it "works" $ void getCorePackages+ it "contains known core packages" $ do+ m <- getCorePackages+ forM_ (words "ghc containers base") $ \p ->+ m `shouldSatisfy` (member (PackageName p))+ it "getCoreExecutables includes known executables" $ do+ s <- getCoreExecutables+ s `shouldSatisfy` member "ghc"+ s `shouldSatisfy` member "hsc2hs"+ s `shouldSatisfy` member "runghc"
+ test/Stackage/PackageIndexSpec.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}+module Stackage.PackageIndexSpec (spec) where++import Stackage.PackageIndex+import Stackage.Prelude+import Test.Hspec+import Distribution.Package (packageId)++spec :: Spec+spec = do+ it "works" $ (runResourceT $ sourcePackageIndex $$ sinkNull :: IO ())+ it "getLatestDescriptions gives reasonable results" $ do+ let f x y = (display x, display y) `member` asSet (setFromList+ [ (asText "base", asText "4.5.0.0")+ , ("does-not-exist", "9999999999999999999")+ ])+ m <- getLatestDescriptions f return+ length m `shouldBe` 1+ p <- simpleParse $ asText "base"+ v <- simpleParse $ asText "4.5.0.0"+ (pkgVersion . packageId <$> m) `shouldBe` singletonMap p v