stackage-curator (empty) → 0.7.0
raw patch · 26 files changed
+3463/−0 lines, 26 filesdep +Cabaldep +QuickCheckdep +aesonsetup-changed
Dependencies added: Cabal, QuickCheck, aeson, async, base, bytestring, classy-prelude-conduit, conduit, conduit-extra, containers, data-default-class, directory, filepath, hspec, http-client, http-client-tls, http-conduit, mono-traversable, mtl, old-locale, optparse-applicative, process, semigroups, stackage, stm, streaming-commons, system-fileio, system-filepath, tar, temporary, text, time, transformers, unix-compat, utf8-string, xml-conduit, yaml, zlib
Files
- ChangeLog.md +68/−0
- LICENSE +20/−0
- README.md +12/−0
- Setup.hs +2/−0
- Stackage/BuildConstraints.hs +234/−0
- Stackage/BuildPlan.hs +214/−0
- Stackage/CheckBuildPlan.hs +162/−0
- Stackage/CompleteBuild.hs +337/−0
- Stackage/CorePackages.hs +53/−0
- Stackage/GhcPkg.hs +104/−0
- Stackage/GithubPings.hs +36/−0
- Stackage/InstallBuild.hs +102/−0
- Stackage/PackageDescription.hs +200/−0
- Stackage/PackageIndex.hs +127/−0
- Stackage/PerformBuild.hs +560/−0
- Stackage/Prelude.hs +116/−0
- Stackage/ServerBundle.hs +271/−0
- Stackage/UpdateBuildPlan.hs +54/−0
- Stackage/Upload.hs +272/−0
- app/stackage.hs +210/−0
- stackage-curator.cabal +105/−0
- test/Spec.hs +1/−0
- test/Stackage/BuildPlanSpec.hs +143/−0
- test/Stackage/CorePackagesSpec.hs +19/−0
- test/Stackage/PackageIndexSpec.hs +21/−0
- test/test-build-constraints.yaml +20/−0
+ ChangeLog.md view
@@ -0,0 +1,68 @@+## 0.7.0++* Renamed to stackage-curator++## 0.6.1++* Switch to V2 upload by default+* --skip-hoogle option++## 0.6.0++* Upload bundle V2 stuff++## 0.5.2++* Upload LTS to Hackage with the name LTSHaskell++## 0.5.1++* `loadBuildConstraints`+* More command line options++## 0.5.0++* Print "Still Alive" while checking, to avoid Travis timeouts+* Include `stackage upload-nightly` command+* Optional plan checking++## 0.4.0++* Command line uses optparse-applicative with additional options+* Library profiling support during build+* Remove cfGlobalFlags (just use package-specific flags)++## 0.3.1++* Added `justCheck` and `stackage check` command line.++## 0.3.0.1++Pre-fetch all packages from Hackage to catch Hackage downtime early.++## 0.3.0.0++* Return progress URL from uploadBundle++## 0.2.1.4++Generate a `core` file in bundles.++## 0.2.1.1++Run postBuild earlier to avoid problems from broken doc uploads.++## 0.2.1.0++* Use TLS manager (to download from Github)++## 0.2.0.0++* Minor fixes+* `pbGlobalInstall`++## 0.1.0.0++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,12 @@+## stackage-curator++This repository contains the code for curating Stackage package sets and+building reusable package databases. It was originally simply called the+stackage package and was part of the stackage repository, but since this is a+tool very few people need to use, we split it into its own package with a name+to indicate it's limited usage (curators only).++More information on Stackage:++* [Stackage Homepage](https://www.stackage.org)+* [Main stackage repo](https://github.com/fpco/stackage)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Stackage/BuildConstraints.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+-- | The constraints on package selection for a new build plan.+module Stackage.BuildConstraints+ ( BuildConstraints (..)+ , PackageConstraints (..)+ , TestState (..)+ , SystemInfo (..)+ , getSystemInfo+ , defaultBuildConstraints+ , toBC+ , BuildConstraintsSource (..)+ , loadBuildConstraints+ ) where++import Control.Monad.Writer.Strict (execWriter, tell)+import Data.Aeson+import qualified Data.Map as Map+import Data.Yaml (decodeEither', decodeFileEither)+import Distribution.Package (Dependency (..))+import Distribution.System (Arch, OS)+import qualified Distribution.System+import Distribution.Version (anyVersion)+import Filesystem (isFile)+import Network.HTTP.Client (Manager, httpLbs, responseBody, Request)+import Stackage.CorePackages+import Stackage.Prelude++data TestState = ExpectSuccess+ | ExpectFailure+ | Don'tBuild -- ^ when the test suite will pull in things we don't want+ deriving (Show, Eq, Ord, Bounded, Enum)++testStateToText :: TestState -> Text+testStateToText ExpectSuccess = "expect-success"+testStateToText ExpectFailure = "expect-failure"+testStateToText Don'tBuild = "do-not-build"++instance ToJSON TestState where+ toJSON = toJSON . testStateToText+instance FromJSON TestState where+ parseJSON = withText "TestState" $ \t ->+ case lookup t states of+ Nothing -> fail $ "Invalid state: " ++ unpack t+ Just v -> return v+ where+ states = asHashMap $ mapFromList+ $ map (\x -> (testStateToText x, x)) [minBound..maxBound]++data SystemInfo = SystemInfo+ { siGhcVersion :: Version+ , siOS :: OS+ , siArch :: Arch+ , siCorePackages :: Map PackageName Version+ , siCoreExecutables :: Set ExeName+ }+ deriving (Show, Eq, Ord)+instance ToJSON SystemInfo where+ toJSON SystemInfo {..} = object+ [ "ghc-version" .= display siGhcVersion+ , "os" .= display siOS+ , "arch" .= display siArch+ , "core-packages" .= Map.mapKeysWith const unPackageName (map display siCorePackages)+ , "core-executables" .= siCoreExecutables+ ]+instance FromJSON SystemInfo where+ parseJSON = withObject "SystemInfo" $ \o -> do+ let helper name = (o .: name) >>= either (fail . show) return . simpleParse+ siGhcVersion <- helper "ghc-version"+ siOS <- helper "os"+ siArch <- helper "arch"+ siCorePackages <- (o .: "core-packages") >>= goPackages+ siCoreExecutables <- o .: "core-executables"+ return SystemInfo {..}+ where+ goPackages = either (fail . show) return+ . mapM simpleParse+ . Map.mapKeysWith const mkPackageName++data BuildConstraints = BuildConstraints+ { bcPackages :: Set PackageName+ -- ^ This does not include core packages.+ , bcPackageConstraints :: PackageName -> PackageConstraints++ , bcSystemInfo :: SystemInfo++ , bcGithubUsers :: Map Text (Set Text)+ -- ^ map an account to set of pingees+ }++data PackageConstraints = PackageConstraints+ { pcVersionRange :: VersionRange+ , pcMaintainer :: Maybe Maintainer+ , pcTests :: TestState+ , pcHaddocks :: TestState+ , pcBuildBenchmarks :: Bool+ , pcFlagOverrides :: Map FlagName Bool+ , pcEnableLibProfile :: Bool+ }+ deriving (Show, Eq)+instance ToJSON PackageConstraints where+ toJSON PackageConstraints {..} = object $ addMaintainer+ [ "version-range" .= display pcVersionRange+ , "tests" .= pcTests+ , "haddocks" .= pcHaddocks+ , "build-benchmarks" .= pcBuildBenchmarks+ , "flags" .= Map.mapKeysWith const unFlagName pcFlagOverrides+ , "library-profiling" .= pcEnableLibProfile+ ]+ where+ addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer+instance FromJSON PackageConstraints where+ parseJSON = withObject "PackageConstraints" $ \o -> do+ pcVersionRange <- (o .: "version-range")+ >>= either (fail . show) return . simpleParse+ pcTests <- o .: "tests"+ pcHaddocks <- o .: "haddocks"+ pcBuildBenchmarks <- o .: "build-benchmarks"+ pcFlagOverrides <- Map.mapKeysWith const mkFlagName <$> o .: "flags"+ pcMaintainer <- o .:? "maintainer"+ pcEnableLibProfile <- fmap (fromMaybe True) (o .:? "library-profiling")+ return PackageConstraints {..}++-- | The proposed plan from the requirements provided by contributors.+--+-- Checks the current directory for a build-constraints.yaml file and uses it+-- if present. If not, downloads from Github.+defaultBuildConstraints :: Manager -> IO BuildConstraints+defaultBuildConstraints = loadBuildConstraints BCSDefault++data BuildConstraintsSource+ = BCSDefault+ | BCSFile FilePath+ | BCSWeb Request+ deriving (Show)++loadBuildConstraints :: BuildConstraintsSource -> Manager -> IO BuildConstraints+loadBuildConstraints bcs man = do+ case bcs of+ BCSDefault -> do+ e <- isFile fp0+ if e+ then loadFile fp0+ else loadReq req0+ BCSFile fp -> loadFile fp+ BCSWeb req -> loadReq req+ where+ fp0 = "build-constraints.yaml"+ req0 = "https://raw.githubusercontent.com/fpco/stackage/master/build-constraints.yaml"++ loadFile fp = decodeFileEither (fpToString fp) >>= either throwIO toBC+ loadReq req = httpLbs req man >>=+ either throwIO toBC . decodeEither' . toStrict . responseBody+++getSystemInfo :: IO SystemInfo+getSystemInfo = do+ siCorePackages <- getCorePackages+ siCoreExecutables <- getCoreExecutables+ siGhcVersion <- getGhcVersion+ return SystemInfo {..}+ where+ -- FIXME consider not hard-coding the next two values+ siOS = Distribution.System.Linux+ siArch = Distribution.System.X86_64++data ConstraintFile = ConstraintFile+ { cfPackageFlags :: Map PackageName (Map FlagName Bool)+ , cfSkippedTests :: Set PackageName+ , cfExpectedTestFailures :: Set PackageName+ , cfExpectedHaddockFailures :: Set PackageName+ , cfSkippedBenchmarks :: Set PackageName+ , cfPackages :: Map Maintainer (Vector Dependency)+ , cfGithubUsers :: Map Text (Set Text)+ , cfSkippedLibProfiling :: Set PackageName+ }++instance FromJSON ConstraintFile where+ parseJSON = withObject "ConstraintFile" $ \o -> do+ cfPackageFlags <- (goPackageMap . fmap goFlagMap) <$> o .: "package-flags"+ cfSkippedTests <- getPackages o "skipped-tests"+ cfExpectedTestFailures <- getPackages o "expected-test-failures"+ cfExpectedHaddockFailures <- getPackages o "expected-haddock-failures"+ cfSkippedBenchmarks <- getPackages o "skipped-benchmarks"+ cfSkippedLibProfiling <- getPackages o "skipped-profiling"+ cfPackages <- o .: "packages"+ >>= mapM (mapM toDep)+ . Map.mapKeysWith const Maintainer+ cfGithubUsers <- o .: "github-users"+ return ConstraintFile {..}+ where+ goFlagMap = Map.mapKeysWith const FlagName+ goPackageMap = Map.mapKeysWith const PackageName+ getPackages o name = (setFromList . map PackageName) <$> o .: name++ toDep :: Monad m => Text -> m Dependency+ toDep = either (fail . show) return . simpleParse++toBC :: ConstraintFile -> IO BuildConstraints+toBC ConstraintFile {..} = do+ bcSystemInfo <- getSystemInfo+ return BuildConstraints {..}+ where+ combine (maintainer, range1) (_, range2) =+ (maintainer, intersectVersionRanges range1 range2)+ revmap = unionsWith combine $ ($ []) $ execWriter+ $ forM_ (mapToList cfPackages)+ $ \(maintainer, deps) -> forM_ deps+ $ \(Dependency name range) ->+ tell (singletonMap name (maintainer, range):)++ bcPackages = Map.keysSet revmap++ bcPackageConstraints name =+ PackageConstraints {..}+ where+ mpair = lookup name revmap+ pcMaintainer = fmap fst mpair+ pcVersionRange = maybe anyVersion snd mpair+ pcEnableLibProfile = not (name `member` cfSkippedLibProfiling)+ pcTests+ | name `member` cfSkippedTests = Don'tBuild+ | name `member` cfExpectedTestFailures = ExpectFailure+ | otherwise = ExpectSuccess+ pcBuildBenchmarks = name `notMember` cfSkippedBenchmarks+ pcHaddocks+ | name `member` cfExpectedHaddockFailures = ExpectFailure++ | otherwise = ExpectSuccess+ pcFlagOverrides = fromMaybe mempty $ lookup name cfPackageFlags++ bcGithubUsers = cfGithubUsers
+ Stackage/BuildPlan.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+-- | Representation of a concrete build plan, and how to generate a new one+-- based on constraints.+module Stackage.BuildPlan+ ( BuildPlan (..)+ , PackagePlan (..)+ , newBuildPlan+ , makeToolMap+ , getLatestAllowedPlans+ ) where++import Control.Monad.State.Strict (execState, get, put)+import Data.Aeson+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Distribution.Compiler+import Distribution.PackageDescription+import Stackage.BuildConstraints+import Stackage.GithubPings+import Stackage.PackageDescription+import Stackage.PackageIndex+import Stackage.Prelude++data BuildPlan = BuildPlan+ { bpSystemInfo :: SystemInfo+ , bpTools :: Vector (PackageName, Version)+ , bpPackages :: Map PackageName PackagePlan+ , bpGithubUsers :: Map Text (Set Text)+ }+ deriving (Show, Eq)++instance ToJSON BuildPlan where+ toJSON BuildPlan {..} = object+ [ "system-info" .= bpSystemInfo+ , "tools" .= map goTool bpTools+ , "packages" .= Map.mapKeysWith const unPackageName bpPackages+ , "github-users" .= bpGithubUsers+ ]+ where+ goTool (k, v) = object+ [ "name" .= display k+ , "version" .= display v+ ]+instance FromJSON BuildPlan where+ parseJSON = withObject "BuildPlan" $ \o -> do+ bpSystemInfo <- o .: "system-info"+ bpTools <- (o .: "tools") >>= mapM goTool+ bpPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages")+ bpGithubUsers <- o .:? "github-users" .!= mempty+ return BuildPlan {..}+ where+ goTool = withObject "Tool" $ \o -> (,)+ <$> ((o .: "name") >>=+ either (fail . show) return . simpleParse . asText)+ <*> ((o .: "version") >>=+ either (fail . show) return . simpleParse . asText)++data PackagePlan = PackagePlan+ { ppVersion :: Version+ , ppGithubPings :: Set Text+ , ppUsers :: Set PackageName+ , ppConstraints :: PackageConstraints+ , ppDesc :: SimpleDesc+ }+ deriving (Show, Eq)++instance ToJSON PackagePlan where+ toJSON PackagePlan {..} = object+ [ "version" .= asText (display ppVersion)+ , "github-pings" .= ppGithubPings+ , "users" .= map unPackageName (unpack ppUsers)+ , "constraints" .= ppConstraints+ , "description" .= ppDesc+ ]+instance FromJSON PackagePlan where+ parseJSON = withObject "PackageBuild" $ \o -> do+ ppVersion <- o .: "version"+ >>= either (fail . show) return+ . simpleParse . asText+ ppGithubPings <- o .:? "github-pings" .!= mempty+ ppUsers <- Set.map PackageName <$> (o .:? "users" .!= mempty)+ ppConstraints <- o .: "constraints"+ ppDesc <- o .: "description"+ return PackagePlan {..}++-- | Make a build plan given these package set and build constraints.+newBuildPlan :: MonadIO m => Map PackageName PackagePlan -> BuildConstraints -> m BuildPlan+newBuildPlan packagesOrig bc@BuildConstraints {..} = liftIO $ do+ let toolMap = makeToolMap packagesOrig+ packages = populateUsers $ removeUnincluded bc toolMap packagesOrig+ toolNames :: [ExeName]+ toolNames = concatMap (Map.keys . sdTools . ppDesc) packages+ tools <- topologicalSortTools toolMap $ mapFromList $ do+ exeName <- toolNames+ guard $ exeName `notMember` siCoreExecutables+ packageName <- maybe mempty setToList $ lookup exeName toolMap+ packagePlan <- maybeToList $ lookup packageName packagesOrig+ return (packageName, packagePlan)+ -- FIXME topologically sort packages? maybe just leave that to the build phase+ return BuildPlan+ { bpSystemInfo = bcSystemInfo+ , bpTools = tools+ , bpPackages = packages+ , bpGithubUsers = bcGithubUsers+ }+ where+ SystemInfo {..} = bcSystemInfo++makeToolMap :: Map PackageName PackagePlan+ -> Map ExeName (Set PackageName)+makeToolMap =+ unionsWith (++) . map go . mapToList+ where+ go (packageName, pp) =+ foldMap go' $ sdProvidedExes $ ppDesc pp+ where+ go' exeName = singletonMap exeName (singletonSet packageName)++topologicalSortTools :: MonadThrow m+ => Map ExeName (Set PackageName)+ -> Map PackageName PackagePlan+ -> m (Vector (PackageName, Version))+topologicalSortTools toolMap = topologicalSort+ ppVersion+ (concatMap (fromMaybe mempty . flip lookup toolMap) . Map.keys . sdTools . ppDesc)++-- | Include only packages which are dependencies of the required packages and+-- their build tools.+removeUnincluded :: BuildConstraints+ -> Map ExeName (Set PackageName)+ -> Map PackageName PackagePlan+ -> Map PackageName PackagePlan+removeUnincluded BuildConstraints {..} toolMap orig =+ mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig+ where+ SystemInfo {..} = bcSystemInfo++ included :: Set PackageName+ included = flip execState mempty $ mapM_ add bcPackages++ add name = do+ inc <- get+ when (name `notMember` inc) $ do+ put $ insertSet name inc+ case lookup name orig of+ Nothing -> return ()+ Just pb -> do+ mapM_ add $ Map.keys $ sdPackages $ ppDesc pb+ forM_ (Map.keys $ sdTools $ ppDesc pb) $+ \exeName -> when (exeName `notMember` siCoreExecutables)+ $ mapM_ add $ fromMaybe mempty $ lookup exeName toolMap++populateUsers :: Map PackageName PackagePlan+ -> Map PackageName PackagePlan+populateUsers orig =+ mapWithKey go orig+ where+ go name pb = pb { ppUsers = foldMap (go2 name) (mapToList orig) }++ go2 dep (user, pb)+ | dep `member` sdPackages (ppDesc pb) = singletonSet user+ | otherwise = mempty++-- | Check whether the given package/version combo meets the constraints+-- currently in place.+isAllowed :: BuildConstraints+ -> PackageName -> Version -> Bool+isAllowed bc = \name version ->+ case lookup name $ siCorePackages $ bcSystemInfo bc of+ Just _ -> False -- never reinstall a core package+ Nothing -> withinRange version $ pcVersionRange $ bcPackageConstraints bc name++mkPackagePlan :: MonadThrow m+ => BuildConstraints+ -> GenericPackageDescription+ -> m PackagePlan+mkPackagePlan bc gpd = do+ ppDesc <- toSimpleDesc CheckCond {..} gpd+ return PackagePlan {..}+ where+ PackageIdentifier name ppVersion = package $ packageDescription gpd+ ppGithubPings = getGithubPings bc gpd+ ppConstraints = bcPackageConstraints bc name+ ppUsers = mempty -- must be filled in later++ ccPackageName = name+ ccOS = siOS+ ccArch = siArch+ ccCompilerFlavor = Distribution.Compiler.GHC+ ccCompilerVersion = siGhcVersion+ ccFlags = flags+ ccIncludeTests = pcTests ppConstraints /= Don'tBuild+ ccIncludeBenchmarks = pcBuildBenchmarks ppConstraints++ SystemInfo {..} = bcSystemInfo bc++ overrides = pcFlagOverrides ppConstraints+ getFlag MkFlag {..} =+ (flagName, fromMaybe flagDefault $ lookup flagName overrides)+ flags = mapFromList $ map getFlag $ genPackageFlags gpd++getLatestAllowedPlans :: MonadIO m => BuildConstraints -> m (Map PackageName PackagePlan)+getLatestAllowedPlans bc =+ getLatestDescriptions+ (isAllowed bc)+ (mkPackagePlan bc)
+ Stackage/CheckBuildPlan.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+-- | Confirm that a build plan has a consistent set of dependencies.+module Stackage.CheckBuildPlan+ ( checkBuildPlan+ , BadBuildPlan+ ) where++import Control.Monad.Writer.Strict (Writer, execWriter, tell)+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import Stackage.BuildConstraints+import Stackage.BuildPlan+import Stackage.PackageDescription+import Stackage.Prelude++-- | Check the build plan for missing deps, wrong versions, etc.+checkBuildPlan :: (MonadThrow m) => BuildPlan -> m ()+checkBuildPlan BuildPlan {..}+ | null errs' = return ()+ | otherwise = throwM errs+ where+ allPackages = map (,mempty) (siCorePackages bpSystemInfo) +++ map (ppVersion &&& M.keys . M.filter libAndExe . sdPackages . ppDesc) bpPackages+ errs@(BadBuildPlan errs') =+ execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages+ -- Only looking at libraries and executables, benchmarks and tests+ -- are allowed to create cycles (e.g. test-framework depends on+ -- text, which uses test-framework in its test-suite).+ libAndExe (DepInfo cs _) = any (flip elem [CompLibrary,CompExecutable]) cs++-- | For a given package name and plan, check that its dependencies are:+--+-- 1. Existent (existing in the provided package map)+-- 2. Within version range+-- 3. Check for dependency cycles.+checkDeps :: Map PackageName (Version,[PackageName])+ -> (PackageName, PackagePlan)+ -> Writer BadBuildPlan ()+checkDeps allPackages (user, pb) =+ mapM_ go $ mapToList $ sdPackages $ ppDesc pb+ where+ go (dep, diRange -> range) =+ case lookup dep allPackages of+ Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap+ Just (version,deps)+ | version `withinRange` range ->+ occursCheck allPackages+ (\d v ->+ tell $ BadBuildPlan $ singletonMap+ (d,v)+ errMap)+ dep+ deps+ []+ | otherwise -> tell $ BadBuildPlan $ singletonMap+ (dep, Just version)+ errMap+ where+ errMap = singletonMap pu range+ pu = PkgUser+ { puName = user+ , puVersion = ppVersion pb+ , puMaintainer = pcMaintainer $ ppConstraints pb+ , puGithubPings = ppGithubPings pb+ }++-- | Check whether the package(s) occurs within its own dependency+-- tree.+occursCheck+ :: Monad m+ => Map PackageName (Version,[PackageName])+ -- ^ All packages.+ -> (PackageName -> Maybe Version -> m ())+ -- ^ Report an erroneous package.+ -> PackageName+ -- ^ Starting package to check for cycles in.+ -> [PackageName]+ -- ^ Dependencies of the package.+ -> [PackageName]+ -- ^ Previously seen packages up the dependency tree.+ -> m ()+occursCheck allPackages reportError =+ go+ where+ go pkg deps seen =+ case find (flip elem seen) deps of+ Just cyclic ->+ reportError cyclic $+ fmap fst (lookup cyclic allPackages)+ Nothing ->+ forM_ deps $+ \pkg' ->+ case lookup pkg' allPackages of+ Just (_v,deps')+ | pkg' /= pkg -> go pkg' deps' seen'+ _ -> return ()+ where seen' = pkg : seen++data PkgUser = PkgUser+ { puName :: PackageName+ , puVersion :: Version+ , puMaintainer :: Maybe Maintainer+ , puGithubPings :: Set Text+ }+ deriving (Eq, Ord)++pkgUserShow1 :: PkgUser -> Text+pkgUserShow1 PkgUser {..} = concat+ [ display puName+ , "-"+ , display puVersion+ ]++pkgUserShow2 :: PkgUser -> Text+pkgUserShow2 PkgUser {..} = unwords+ $ (maybe "No maintainer" unMaintainer puMaintainer ++ ".")+ : map (cons '@') (setToList puGithubPings)++newtype BadBuildPlan =+ BadBuildPlan (Map (PackageName, Maybe Version) (Map PkgUser VersionRange))+ deriving Typeable+instance Exception BadBuildPlan+instance Show BadBuildPlan where+ show (BadBuildPlan errs) =+ unpack $ concatMap go $ mapToList errs+ where+ go ((dep, mdepVer), users) = unlines+ $ ""+ : showDepVer dep mdepVer+ : map showUser (mapToList users)++ showDepVer :: PackageName -> Maybe Version -> Text+ showDepVer dep Nothing = display dep ++ " (not present) depended on by:"+ showDepVer dep (Just version) = concat+ [ display dep+ , "-"+ , display version+ , " depended on by:"+ ]++ showUser :: (PkgUser, VersionRange) -> Text+ showUser (pu, range) = concat+ [ "- "+ , pkgUserShow1 pu+ , " ("+ -- add a space after < to avoid confusing Markdown processors (like+ -- Github's issue tracker)+ , T.replace "<" "< " $ display range+ , "). "+ , pkgUserShow2 pu+ ]++instance Monoid BadBuildPlan where+ mempty = BadBuildPlan mempty+ mappend (BadBuildPlan x) (BadBuildPlan y) =+ BadBuildPlan $ unionWith (unionWith intersectVersionRanges) x y
+ Stackage/CompleteBuild.hs view
@@ -0,0 +1,337 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Stackage.CompleteBuild+ ( BuildType (..)+ , BumpType (..)+ , BuildFlags (..)+ , completeBuild+ , justCheck+ , justUploadNightly+ , getStackageAuthToken+ ) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (withAsync)+import Data.Default.Class (def)+import Data.Semigroup (Max (..), Option (..))+import Data.Text.Read (decimal)+import Data.Time+import Data.Yaml (decodeFileEither, encodeFile)+import Network.HTTP.Client+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Stackage.BuildConstraints+import Stackage.BuildPlan+import Stackage.CheckBuildPlan+import Stackage.PerformBuild+import Stackage.Prelude+import Stackage.ServerBundle+import Stackage.UpdateBuildPlan+import Stackage.Upload+import System.Environment (lookupEnv)+import System.IO (BufferMode (LineBuffering), hSetBuffering)++-- | Flags passed in from the command line.+data BuildFlags = BuildFlags+ { bfEnableTests :: !Bool+ , bfEnableHaddock :: !Bool+ , bfDoUpload :: !Bool+ , bfEnableLibProfile :: !Bool+ , bfEnableExecDyn :: !Bool+ , bfVerbose :: !Bool+ , bfSkipCheck :: !Bool+ , bfUploadV1 :: !Bool+ , bfServer :: !StackageServer+ , bfBuildHoogle :: !Bool+ } deriving (Show)++data BuildType = Nightly | LTS BumpType+ deriving (Show, Read, Eq, Ord)++data BumpType = Major | Minor+ deriving (Show, Read, Eq, Ord)++data Settings = Settings+ { plan :: BuildPlan+ , planFile :: FilePath+ , buildDir :: FilePath+ , logDir :: FilePath+ , title :: Text -> Text -- ^ GHC version -> title+ , slug :: Text+ , setArgs :: Text -> UploadBundle -> UploadBundle+ , postBuild :: IO ()+ , distroName :: Text -- ^ distro name on Hackage+ , snapshotType :: SnapshotType+ , bundleDest :: FilePath+ }++nightlyPlanFile :: Text -- ^ day+ -> FilePath+nightlyPlanFile day = fpFromText ("nightly-" ++ day) <.> "yaml"++nightlySettings :: Text -- ^ day+ -> BuildPlan+ -> Settings+nightlySettings day plan' = Settings+ { planFile = nightlyPlanFile day+ , buildDir = fpFromText $ "builds/nightly"+ , logDir = fpFromText $ "logs/stackage-nightly-" ++ day+ , title = \ghcVer -> concat+ [ "Stackage Nightly "+ , day+ , ", GHC "+ , ghcVer+ ]+ , slug = slug'+ , setArgs = \ghcVer ub -> ub { ubNightly = Just ghcVer }+ , plan = plan'+ , postBuild = return ()+ , distroName = "Stackage"+ , snapshotType = STNightly+ , bundleDest = fpFromText $ "stackage-nightly-" ++ day ++ ".bundle"+ }+ where+ slug' = "nightly-" ++ day++getSettings :: Manager -> BuildType -> IO Settings+getSettings man Nightly = do+ day <- tshow . utctDay <$> getCurrentTime+ bc <- defaultBuildConstraints man+ pkgs <- getLatestAllowedPlans bc+ plan' <- newBuildPlan pkgs bc+ return $ nightlySettings day plan'+getSettings man (LTS bumpType) = do+ Option mlts <- fmap (fmap getMax) $ runResourceT+ $ sourceDirectory "."+ $$ foldMapC (Option . fmap Max . parseLTSVer . filename)++ (new, plan') <- case bumpType of+ Major -> do+ let new =+ case mlts of+ Nothing -> LTSVer 0 0+ Just (LTSVer x _) -> LTSVer (x + 1) 0+ bc <- defaultBuildConstraints man+ pkgs <- getLatestAllowedPlans bc+ plan' <- newBuildPlan pkgs bc+ return (new, plan')+ Minor -> do+ old <- maybe (error "No LTS plans found in current directory") return mlts+ oldplan <- decodeFileEither (fpToString $ renderLTSVer old)+ >>= either throwM return+ let new = incrLTSVer old+ let bc = updateBuildConstraints oldplan+ pkgs <- getLatestAllowedPlans bc+ plan' <- newBuildPlan pkgs bc+ return (new, plan')++ let newfile = renderLTSVer new++ return Settings+ { planFile = newfile+ , buildDir = fpFromText $ "builds/lts"+ , logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new+ , title = \ghcVer -> concat+ [ "LTS Haskell "+ , tshow new+ , ", GHC "+ , ghcVer+ ]+ , slug = "lts-" ++ tshow new+ , setArgs = \_ ub -> ub { ubLTS = Just $ tshow new }+ , plan = plan'+ , postBuild = do+ let git args = withCheckedProcess+ (proc "git" args) $ \ClosedStream Inherited Inherited ->+ return ()+ putStrLn "Committing new LTS file to Git"+ git ["add", fpToString newfile]+ git ["commit", "-m", "Added new LTS release: " ++ show new]+ putStrLn "Pushing to Git repository"+ git ["push"]+ , distroName = "LTSHaskell"+ , snapshotType =+ case new of+ LTSVer x y -> STLTS x y+ , bundleDest = fpFromText $ "stackage-lts-" ++ tshow new ++ ".bundle"+ }++data LTSVer = LTSVer !Int !Int+ deriving (Eq, Ord)+instance Show LTSVer where+ show (LTSVer x y) = concat [show x, ".", show y]+incrLTSVer :: LTSVer -> LTSVer+incrLTSVer (LTSVer x y) = LTSVer x (y + 1)++parseLTSVer :: FilePath -> Maybe LTSVer+parseLTSVer fp = do+ w <- stripPrefix "lts-" $ fpToText fp+ x <- stripSuffix ".yaml" w+ Right (major, y) <- Just $ decimal x+ z <- stripPrefix "." y+ Right (minor, "") <- Just $ decimal z+ return $ LTSVer major minor+renderLTSVer :: LTSVer -> FilePath+renderLTSVer lts = fpFromText $ concat+ [ "lts-"+ , tshow lts+ , ".yaml"+ ]++-- | Just print a message saying "still alive" every minute, to appease Travis.+stillAlive :: IO () -> IO ()+stillAlive inner =+ withAsync (printer 1) $ const inner+ where+ printer i = forever $ do+ threadDelay 60000000+ putStrLn $ "Still alive: " ++ tshow i+ printer $! i + 1++-- | Generate and check a new build plan, but do not execute it.+--+-- Since 0.3.1+justCheck :: IO ()+justCheck = stillAlive $ withManager tlsManagerSettings $ \man -> do+ putStrLn "Loading build constraints"+ bc <- defaultBuildConstraints man++ putStrLn "Creating build plan"+ plans <- getLatestAllowedPlans bc+ plan <- newBuildPlan plans bc++ putStrLn $ "Writing build plan to check-plan.yaml"+ encodeFile "check-plan.yaml" plan++ putStrLn "Checking plan"+ checkBuildPlan plan++ putStrLn "Plan seems valid!"++getPerformBuild :: BuildFlags -> Settings -> PerformBuild+getPerformBuild buildFlags Settings {..} = PerformBuild+ { pbPlan = plan+ , pbInstallDest = buildDir+ , pbLogDir = logDir+ , pbLog = hPut stdout+ , pbJobs = 8+ , pbGlobalInstall = False+ , pbEnableTests = bfEnableTests buildFlags+ , pbEnableHaddock = bfEnableHaddock buildFlags+ , pbEnableLibProfiling = bfEnableLibProfile buildFlags+ , pbEnableExecDyn = bfEnableExecDyn buildFlags+ , pbVerbose = bfVerbose buildFlags+ , pbAllowNewer = bfSkipCheck buildFlags+ , pbBuildHoogle = bfBuildHoogle buildFlags+ }++-- | Make a complete plan, build, test and upload bundle, docs and+-- distro.+completeBuild :: BuildType -> BuildFlags -> IO ()+completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do+ hSetBuffering stdout LineBuffering++ putStrLn $ "Loading settings for: " ++ tshow buildType+ settings@Settings {..} <- getSettings man buildType++ putStrLn $ "Writing build plan to: " ++ fpToText planFile+ encodeFile (fpToString planFile) plan++ if bfSkipCheck buildFlags+ then putStrLn "Skipping build plan check"+ else do+ putStrLn "Checking build plan"+ checkBuildPlan plan++ putStrLn "Performing build"+ let pb = getPerformBuild buildFlags settings+ performBuild pb >>= mapM_ putStrLn++ putStrLn $ "Creating bundle (v2) at: " ++ fpToText bundleDest+ createBundleV2 CreateBundleV2+ { cb2Plan = plan+ , cb2Type = snapshotType+ , cb2DocsDir = pbDocDir pb+ , cb2Dest = bundleDest+ }++ when (bfDoUpload buildFlags) $+ finallyUpload+ (not $ bfUploadV1 buildFlags)+ (bfServer buildFlags)+ settings+ man++justUploadNightly+ :: Text -- ^ nightly date+ -> IO ()+justUploadNightly day = do+ plan <- decodeFileEither (fpToString $ nightlyPlanFile day)+ >>= either throwM return+ withManager tlsManagerSettings $ finallyUpload False def $ nightlySettings day plan++getStackageAuthToken :: IO Text+getStackageAuthToken = do+ mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN"+ case mtoken of+ Nothing -> decodeUtf8 <$> readFile "/auth-token"+ Just token -> return $ pack token++-- | The final part of the complete build process: uploading a bundle,+-- docs and a distro to hackage.+finallyUpload :: Bool -- ^ use v2 upload+ -> StackageServer+ -> Settings -> Manager -> IO ()+finallyUpload useV2 server settings@Settings{..} man = do+ putStrLn "Uploading bundle to Stackage Server"++ token <- getStackageAuthToken++ if useV2+ then do+ res <- flip uploadBundleV2 man UploadBundleV2+ { ub2Server = server+ , ub2AuthToken = token+ , ub2Bundle = bundleDest+ }+ putStrLn $ "New snapshot available at: " ++ res+ else do+ now <- epochTime+ let ghcVer = display $ siGhcVersion $ bpSystemInfo plan+ (ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def+ { ubContents = serverBundle now (title ghcVer) slug plan+ , ubAuthToken = token+ }+ putStrLn $ "New ident: " ++ unSnapshotIdent ident+ forM_ mloc $ \loc ->+ putStrLn $ "Track progress at: " ++ loc++ putStrLn "Uploading docs to Stackage Server"+ res1 <- tryAny $ uploadDocs UploadDocs+ { udServer = def+ , udAuthToken = token+ , udDocs = pbDocDir pb+ , udSnapshot = ident+ } man+ putStrLn $ "Doc upload response: " ++ tshow res1++ putStrLn "Uploading doc map"+ tryAny (uploadDocMap UploadDocMap+ { udmServer = def+ , udmAuthToken = token+ , udmSnapshot = ident+ , udmDocDir = pbDocDir pb+ , udmPlan = plan+ } man) >>= print++ postBuild `catchAny` print++ ecreds <- tryIO $ readFile "/hackage-creds"+ case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of+ [username, password] -> do+ putStrLn "Uploading as Hackage distro"+ res2 <- uploadHackageDistroNamed distroName plan username password man+ putStrLn $ "Distro upload response: " ++ tshow res2+ _ -> putStrLn "No creds found, skipping Hackage distro upload"+ where+ pb = getPerformBuild (error "finallyUpload.buildFlags") settings
+ Stackage/CorePackages.hs 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/GhcPkg.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+-- | General commands related to ghc-pkg.++module Stackage.GhcPkg+ ( setupPackageDatabase+ ) where++import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.Conduit.Process+import qualified Data.Conduit.Text as CT+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import Distribution.Compat.ReadP+import Distribution.Package+import Distribution.Text (parse)+import Filesystem.Path.CurrentOS (FilePath)+import qualified Filesystem.Path.CurrentOS as FP+import Data.Map (Map)+import Data.Version (Version)+import Stackage.Prelude+import Filesystem (removeTree)++setupPackageDatabase+ :: Maybe FilePath -- ^ database location, Nothing if using global DB+ -> FilePath -- ^ documentation root+ -> (ByteString -> IO ()) -- ^ logging+ -> Map PackageName Version -- ^ packages and versions to be installed+ -> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package+ -> IO (Set PackageName) -- ^ packages remaining in the database after cleanup+setupPackageDatabase mdb docDir log' toInstall onUnregister = do+ registered1 <- getRegisteredPackages flags+ forM_ registered1 $ \pi@(PackageIdentifier name version) ->+ case lookup name toInstall of+ Just version' | version /= version' -> unregisterPackage log' onUnregister docDir flags pi+ _ -> return ()+ broken <- getBrokenPackages flags+ forM_ broken $ unregisterPackage log' onUnregister docDir flags+ foldMap (\(PackageIdentifier name _) -> singletonSet name)+ <$> getRegisteredPackages flags+ where+ flags = ghcPkgFlags mdb++ghcPkgFlags :: Maybe FilePath -> [String]+ghcPkgFlags mdb =+ "--no-user-package-db" :+ case mdb of+ Nothing -> ["--global"]+ Just fp -> ["--package-db=" ++ fpToString fp]++-- | Get broken packages.+getBrokenPackages :: [String] -> IO [PackageIdentifier]+getBrokenPackages flags = do+ (_,ps) <- sourceProcessWithConsumer+ (proc+ "ghc-pkg"+ ("check" : "--simple-output" : flags))+ (CT.decodeUtf8 $= CT.lines $= CL.consume)+ return (mapMaybe parsePackageIdent (T.words (T.unlines ps)))++-- | Get available packages.+getRegisteredPackages :: [String] -> IO [PackageIdentifier]+getRegisteredPackages flags = do+ (_,ps) <- sourceProcessWithConsumer+ (proc+ "ghc-pkg"+ ("list" : "--simple-output" : flags))+ (CT.decodeUtf8 $= CT.lines $= CL.consume)+ return (mapMaybe parsePackageIdent (T.words (T.unlines ps)))++-- | Parse a package identifier: foo-1.2.3+parsePackageIdent :: Text -> Maybe PackageIdentifier+parsePackageIdent = fmap fst .+ listToMaybe .+ filter (null . snd) .+ readP_to_S parse . T.unpack++-- | Unregister a package.+unregisterPackage :: (ByteString -> IO ()) -- ^ log func+ -> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package+ -> FilePath -- ^ doc directory+ -> [String] -> PackageIdentifier -> IO ()+unregisterPackage log' onUnregister docDir flags ident@(PackageIdentifier name _) = do+ log' $ "Unregistering " ++ encodeUtf8 (display ident) ++ "\n"+ onUnregister ident++ -- Delete libraries+ sourceProcessWithConsumer+ (proc "ghc-pkg" ("describe" : flags ++ [unpack $ display ident]))+ (CT.decodeUtf8+ $= CT.lines+ $= CL.mapMaybe parseLibraryDir+ $= CL.mapM_ (void . tryIO . removeTree))++ void (readProcessWithExitCode+ "ghc-pkg"+ ("unregister": flags ++ ["--force", unpack $ display name])+ "")++ void $ tryIO $ removeTree $ docDir </> fpFromText (display ident)+ where+ parseLibraryDir = fmap fpFromText . stripPrefix "library-dirs: "
+ Stackage/GithubPings.hs 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/InstallBuild.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Stackage.InstallBuild+ ( InstallFlags (..)+ , BuildPlanSource (..)+ , installBuild+ ) where++import qualified Codec.Archive.Tar as Tar+import qualified Codec.Compression.GZip as GZip+import qualified Data.Yaml as Yaml+import Network.HTTP.Client+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Stackage.BuildPlan+import Stackage.CheckBuildPlan+import Stackage.PerformBuild+import Stackage.Prelude+import System.IO (BufferMode (LineBuffering), hSetBuffering)++-- | Flags passed in from the command line.+data InstallFlags = InstallFlags+ { ifPlanSource :: !BuildPlanSource+ , ifInstallDest :: !FilePath+ , ifLogDir :: !(Maybe FilePath)+ , ifJobs :: !Int+ , ifGlobalInstall :: !Bool+ , ifEnableTests :: !Bool+ , ifEnableHaddock :: !Bool+ , ifEnableLibProfiling :: !Bool+ , ifEnableExecDyn :: !Bool+ , ifVerbose :: !Bool+ , ifSkipCheck :: !Bool+ , ifBuildHoogle :: !Bool+ } deriving (Show)++-- | Source for build plan.+data BuildPlanSource = BPSBundleWeb String+ | BPSFile FilePath+ deriving (Show)++getPerformBuild :: BuildPlan -> InstallFlags -> PerformBuild+getPerformBuild plan InstallFlags{..} =+ PerformBuild+ { pbPlan = plan+ , pbInstallDest = ifInstallDest+ , pbLogDir = fromMaybe (ifInstallDest </> "logs") ifLogDir+ , pbLog = hPut stdout+ , pbJobs = ifJobs+ , pbGlobalInstall = ifGlobalInstall+ , pbEnableTests = ifEnableTests+ , pbEnableHaddock = ifEnableHaddock+ , pbEnableLibProfiling = ifEnableLibProfiling+ , pbEnableExecDyn = ifEnableExecDyn+ , pbVerbose = ifVerbose+ , pbAllowNewer = ifSkipCheck+ , pbBuildHoogle = ifBuildHoogle+ }++-- | Install stackage from an existing build plan.+installBuild :: InstallFlags -> IO ()+installBuild installFlags@InstallFlags{..} = do+ hSetBuffering stdout LineBuffering++ putStrLn $ "Loading build plan"+ plan <- case ifPlanSource of+ BPSBundleWeb url -> withManager tlsManagerSettings $ \man -> do+ req <- parseUrl url+ res <- httpLbs req man+ planBSL <- getPlanEntry $ Tar.read $ GZip.decompress (responseBody res)+ decodeBuildPlan planBSL+ BPSFile path -> Yaml.decodeFileEither (fpToString path) >>= either throwM return++ if ifSkipCheck+ then putStrLn "Skipping build plan check"+ else do+ putStrLn "Checking build plan"+ checkBuildPlan plan++ putStrLn "Performing build"+ performBuild (getPerformBuild plan installFlags) >>= mapM_ putStrLn++ where+ getPlanEntry Tar.Done = throwIO NoBuildPlanException+ getPlanEntry (Tar.Fail e) = throwIO e+ getPlanEntry (Tar.Next entry entries)+ | Tar.entryPath entry == "build-plan.yaml" =+ case Tar.entryContent entry of+ Tar.NormalFile bs _ -> return bs+ _ -> throwIO NoBuildPlanException+ | otherwise = getPlanEntry entries++ decodeBuildPlan =+ either throwIO return . Yaml.decodeEither' . toStrict++data InstallBuildException = NoBuildPlanException+ deriving (Typeable)+instance Exception InstallBuildException+instance Show InstallBuildException where+ show NoBuildPlanException = "Bundle has missing or invalid build-plan.yaml"
+ Stackage/PackageDescription.hs 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 (== '/') $ T.replace "\\" "/" t1+ p <- simpleParse p'+ t3 <- maybe (throwM $ InvalidCabalPath t1 "no slash") return+ $ stripPrefix "/" t2+ let (v', t4) = break (== '/') t3+ v <- simpleParse v'+ when (t4 /= cons '/' p') $ throwM $ InvalidCabalPath t1 $ "Expected at end: " ++ p'+ return (p, v)++data InvalidCabalPath = InvalidCabalPath Text Text+ deriving (Show, Typeable)+instance Exception InvalidCabalPath++data CabalParseException = CabalParseException FilePath PError+ | MismatchedNameVersion FilePath PackageName PackageName Version Version+ deriving (Show, Typeable)+instance Exception CabalParseException++-- | Get all of the latest descriptions for name/version pairs matching the+-- given criterion.+getLatestDescriptions :: MonadIO m+ => (PackageName -> Version -> Bool)+ -> (GenericPackageDescription -> IO desc)+ -> m (Map PackageName desc)+getLatestDescriptions f parseDesc = liftIO $ do+ m <- runResourceT $ sourcePackageIndex $$ filterC f' =$ foldlC add mempty+ forM m $ \ucf -> liftIO $ ucfParse ucf >>= parseDesc+ where+ f' ucf = f (ucfName ucf) (ucfVersion ucf)+ add m ucf =+ case lookup name m of+ Just ucf' | ucfVersion ucf < ucfVersion ucf' -> m+ _ -> insertMap name ucf m+ where+ name = ucfName ucf
+ Stackage/PerformBuild.hs view
@@ -0,0 +1,560 @@+-- | Perform an actual build, generate a binary package database and a+-- documentation directory in the process.+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Stackage.PerformBuild+ ( performBuild+ , PerformBuild (..)+ , BuildException (..)+ , pbDocDir+ ) where++import Control.Concurrent.Async (async)+import Control.Concurrent.STM.TSem+import Control.Monad.Writer.Strict (execWriter, tell)+import qualified Data.Map as Map+import Data.NonNull (fromNullable)+import Filesystem (canonicalizePath, createTree,+ getWorkingDirectory, isDirectory,+ removeTree, rename, isFile, removeFile)+import Filesystem.Path (parent)+import qualified Filesystem.Path as F+import Stackage.BuildConstraints+import Stackage.BuildPlan+import Stackage.GhcPkg+import Stackage.PackageDescription+import Stackage.Prelude hiding (pi)+import System.Directory (findExecutable)+import System.Environment (getEnvironment)+import System.IO (IOMode (WriteMode),+ openBinaryFile)+import System.IO.Temp (withSystemTempDirectory)++data BuildException = BuildException (Map PackageName BuildFailure) [Text]+ deriving Typeable+instance Exception BuildException+instance Show BuildException where+ show (BuildException m warnings) =+ unlines $ map go (mapToList m) ++ map unpack warnings+ where+ go (PackageName name, bf) = concat+ [ name+ , ": "+ , show bf+ ]++data BuildFailure = DependencyFailed PackageName+ | DependencyMissing PackageName+ | ToolMissing ExeName+ | NotImplemented+ | BuildFailureException SomeException+ deriving (Show, Typeable)+instance Exception BuildFailure++data PerformBuild = PerformBuild+ { pbPlan :: BuildPlan+ , pbInstallDest :: FilePath+ , pbLog :: ByteString -> IO ()+ , pbLogDir :: FilePath+ , pbJobs :: Int+ , pbGlobalInstall :: Bool+ -- ^ Register packages in the global database+ , pbEnableTests :: Bool+ , pbEnableHaddock :: Bool+ , pbEnableLibProfiling :: Bool+ , pbEnableExecDyn :: Bool+ , pbVerbose :: Bool+ , pbAllowNewer :: Bool+ -- ^ Pass --allow-newer to cabal configure+ , pbBuildHoogle :: Bool+ -- ^ Should we build Hoogle database?+ --+ -- May be disabled due to: https://ghc.haskell.org/trac/ghc/ticket/9921+ }++data PackageInfo = PackageInfo+ { piPlan :: PackagePlan+ , piName :: PackageName+ , piResult :: TMVar Bool+ }++waitForDeps :: Map ExeName (Set PackageName)+ -> Map PackageName PackageInfo+ -> Set Component+ -> BuildPlan+ -> PackageInfo+ -> IO a+ -> IO a+waitForDeps toolMap packageMap activeComps bp pi action = do+ atomically $ do+ mapM_ checkPackage $ Map.keys $ filterUnused $ sdPackages $ ppDesc $ piPlan pi+ forM_ (Map.keys $ filterUnused $ sdTools $ ppDesc $ piPlan pi) $ \exe -> do+ case lookup exe toolMap >>= fromNullable . map checkPackage . setToList of+ Nothing+ | isCoreExe exe -> return ()+ -- https://github.com/jgm/zip-archive/issues/23+ -- - | otherwise -> throwSTM $ ToolMissing exe+ | otherwise -> return ()+ Just packages -> ofoldl1' (<|>) packages+ action+ where+ filterUnused :: Ord key => Map key DepInfo -> Map key DepInfo+ filterUnused =+ mapFromList . filter (go . snd) . mapToList+ where+ go = not . null . intersection activeComps . diComponents++ checkPackage package | package == piName pi = return ()+ checkPackage package =+ case lookup package packageMap of+ Nothing+ | isCore package -> return ()+ | otherwise -> throwSTM $ DependencyMissing package+ Just dep -> do+ res <- readTMVar $ piResult dep+ unless res $ throwSTM $ DependencyFailed package++ isCore = (`member` siCorePackages (bpSystemInfo bp))+ isCoreExe = (`member` siCoreExecutables (bpSystemInfo bp))++withCounter :: TVar Int -> IO a -> IO a+withCounter counter = bracket_+ (atomically $ modifyTVar counter (+ 1))+ (atomically $ modifyTVar counter (subtract 1))++withTSem :: TSem -> IO a -> IO a+withTSem sem = bracket_ (atomically $ waitTSem sem) (atomically $ signalTSem sem)++-- | Returns @Nothing@ if installing to a global database+pbDatabase :: PerformBuild -> Maybe FilePath+pbDatabase pb+ | pbGlobalInstall pb = Nothing+ | otherwise = Just $ pbInstallDest pb </> "pkgdb"++pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath+pbBinDir pb = pbInstallDest pb </> "bin"+pbLibDir pb = pbInstallDest pb </> "lib"+pbDataDir pb = pbInstallDest pb </> "share"+pbDocDir pb = pbInstallDest pb </> "doc"++-- | Directory keeping previous result info+pbPrevResDir :: PerformBuild -> FilePath+pbPrevResDir pb = pbInstallDest pb </> "prevres"++performBuild :: PerformBuild -> IO [Text]+performBuild pb = do+ cwd <- getWorkingDirectory+ performBuild' pb+ { pbInstallDest = cwd </> pbInstallDest pb+ , pbLogDir = cwd </> pbLogDir pb+ }++performBuild' :: PerformBuild -> IO [Text]+performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do+ -- First make sure to fetch all of the dependencies... just in case Hackage+ -- has an outage. Don't feel like wasting hours of CPU time.+ pbLog $ encodeUtf8 "Pre-fetching all packages\n"+ let toDownload = flip map (mapToList $ bpPackages pbPlan)+ $ \(name, plan) -> unpack $ concat+ [ display name+ , "-"+ , display $ ppVersion plan+ ]+ withCheckedProcess+ (proc "cabal"+ $ "fetch"+ : "--no-dependencies"+ : toDownload)+ $ \ClosedStream Inherited Inherited -> return ()++ let removeTree' fp = whenM (isDirectory fp) (removeTree fp)+ removeTree' pbLogDir++ forM_ (pbDatabase pb) $ \db ->+ unlessM (isFile $ db </> "package.cache") $ do+ createTree $ parent db+ withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])+ $ \ClosedStream Inherited Inherited -> return ()+ pbLog $ encodeUtf8 "Copying built-in Haddocks\n"+ copyBuiltInHaddocks (pbDocDir pb)++ sem <- atomically $ newTSem pbJobs+ active <- newTVarIO (0 :: Int)+ let toolMap = makeToolMap $ bpPackages pbPlan+ packageMap <- fmap fold $ forM (mapToList $ bpPackages pbPlan)+ $ \(name, plan) -> do+ let piPlan = plan+ piName = name+ piResult <- newEmptyTMVarIO+ return $ singletonMap name PackageInfo {..}++ errsVar <- newTVarIO mempty+ warningsVar <- newTVarIO id+ mutex <- newMVar ()+ env <- getEnvironment+ haddockFiles <- newTVarIO mempty++ registeredPackages <- setupPackageDatabase+ (pbDatabase pb)+ (pbDocDir pb)+ pbLog+ (ppVersion <$> bpPackages pbPlan)+ (deletePreviousResults pb)++ forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages+ SingleBuild+ { sbSem = sem+ , sbErrsVar = errsVar+ , sbWarningsVar = warningsVar+ , sbActive = active+ , sbToolMap = toolMap+ , sbPackageMap = packageMap+ , sbBuildDir = builddir+ , sbPackageInfo = pi+ , sbRegisterMutex = mutex+ , sbModifiedEnv = maybe+ id+ (\db -> (("HASKELL_PACKAGE_SANDBOX", fpToString db):))+ (pbDatabase pb)+ (filter allowedEnv $ map fixEnv env)+ , sbHaddockFiles = haddockFiles+ }++ void $ tryAny $ atomically $ readTVar active >>= checkSTM . (== 0)++ warnings <- ($ []) <$> readTVarIO warningsVar+ errs <- readTVarIO errsVar+ when (not $ null errs) $ throwM $ BuildException errs warnings+ return warnings+ where+ withBuildDir f = withSystemTempDirectory "stackage-build" (f . fpFromString)++ fixEnv (p, x)+ -- Thank you Windows having case-insensitive environment variables...+ | toUpper p == "PATH" = (p, fpToString (pbBinDir pb) ++ pathSep : x)+ | otherwise = (p, x)++ allowedEnv (k, _) = k `notMember` bannedEnvs++ -- | Separate for the PATH environment variable+ pathSep :: Char+#ifdef mingw32_HOST_OS+ pathSep = ';'+#else+ pathSep = ':'+#endif++-- | Environment variables we don't allow to be passed on to child processes.+bannedEnvs :: Set String+bannedEnvs = setFromList+ [ "STACKAGE_AUTH_TOKEN"+ ]++data SingleBuild = SingleBuild+ { sbSem :: TSem+ , sbErrsVar :: TVar (Map PackageName BuildFailure)+ , sbWarningsVar :: TVar ([Text] -> [Text])+ , sbActive :: TVar Int+ , sbToolMap :: Map ExeName (Set PackageName)+ , sbPackageMap :: Map PackageName PackageInfo+ , sbBuildDir :: FilePath+ , sbPackageInfo :: PackageInfo+ , sbRegisterMutex :: MVar ()+ , sbModifiedEnv :: [(String, String)]+ , sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file+ }++singleBuild :: PerformBuild+ -> Set PackageName -- ^ registered packages+ -> SingleBuild -> IO ()+singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =+ withCounter sbActive+ $ handle updateErrs+ $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))+ $ inner+ where+ libComps = setFromList [CompLibrary, CompExecutable]+ testComps = insertSet CompTestSuite libComps+ inner = do+ let wfd comps =+ waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo+ . withTSem sbSem+ withUnpacked <- wfd libComps buildLibrary++ wfd testComps (runTests withUnpacked)++ pname = piName sbPackageInfo+ pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo)+ name = display pname+ namever = concat+ [ name+ , "-"+ , display $ ppVersion $ piPlan sbPackageInfo+ ]++ runIn wdir getOutH cmd args = do+ outH <- getOutH+ withCheckedProcess (cp outH) $ \ClosedStream UseProvidedHandle UseProvidedHandle ->+ (return () :: IO ())+ where+ cp outH = (proc (unpack $ asText cmd) (map (unpack . asText) args))+ { cwd = Just $ fpToString wdir+ , std_out = UseHandle outH+ , std_err = UseHandle outH+ , env = Just sbModifiedEnv+ }+ runParent = runIn sbBuildDir+ runChild = runIn childDir+ childDir = sbBuildDir </> fpFromText namever++ log' t = do+ i <- readTVarIO sbActive+ errs <- readTVarIO sbErrsVar+ pbLog $ encodeUtf8 $ concat+ [ t+ , " (pending: "+ , tshow i+ , ", failures: "+ , tshow $ length errs+ , ")\n"+ ]+ libOut = pbLogDir </> fpFromText namever </> "build.out"+ testOut = pbLogDir </> fpFromText namever </> "test.out"+ testRunOut = pbLogDir </> fpFromText namever </> "test-run.out"++ wf fp inner' = do+ ref <- newIORef Nothing+ let cleanup = do+ mh <- readIORef ref+ forM_ mh hClose+ getH = do+ mh <- readIORef ref+ case mh of+ Just h -> return h+ Nothing -> mask_ $ do+ createTree $ parent fp+ h <- openBinaryFile (fpToString fp) WriteMode+ writeIORef ref $ Just h+ return h++ inner' getH `finally` cleanup++ configArgs = ($ []) $ execWriter $ do+ when pbAllowNewer $ tell' "--allow-newer"+ tell' "--package-db=clear"+ tell' "--package-db=global"+ forM_ (pbDatabase pb) $ \db -> tell' $ "--package-db=" ++ fpToText db+ tell' $ "--libdir=" ++ fpToText (pbLibDir pb)+ tell' $ "--bindir=" ++ fpToText (pbBinDir pb)+ tell' $ "--datadir=" ++ fpToText (pbDataDir pb)+ tell' $ "--docdir=" ++ fpToText (pbDocDir pb)+ tell' $ "--flags=" ++ flags+ when (pbEnableLibProfiling && pcEnableLibProfile) $+ tell' "--enable-library-profiling"+ when pbEnableExecDyn $ tell' "--enable-executable-dynamic"+ where+ tell' x = tell (x:)++ flags :: Text+ flags = unwords $ map go $ mapToList pcFlagOverrides+ where+ go (name', isOn) = concat+ [ if isOn then "" else "-"+ , unFlagName name'+ ]++ PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo++ buildLibrary = wf libOut $ \getOutH -> do+ let run a b = do when pbVerbose $ log' (unwords (a : b))+ runChild getOutH a b++ isUnpacked <- newIORef False+ let withUnpacked inner = do+ unlessM (readIORef isUnpacked) $ do+ log' $ "Unpacking " ++ namever+ runParent getOutH "cabal" ["unpack", namever]+ writeIORef isUnpacked True+ inner++ isConfiged <- newIORef False+ let withConfiged inner = withUnpacked $ do+ unlessM (readIORef isConfiged) $ do+ log' $ "Configuring " ++ namever+ run "cabal" $ "configure" : configArgs+ writeIORef isConfiged True+ inner++ prevBuildResult <- getPreviousResult pb Build pident+ unless (prevBuildResult == PRSuccess) $ withConfiged $ do+ assert (pname `notMember` registeredPackages) $ do+ deletePreviousResults pb pident++ log' $ "Building " ++ namever+ run "cabal" ["build"]++ log' $ "Copying/registering " ++ namever+ run "cabal" ["copy"]+ withMVar sbRegisterMutex $ const $+ run "cabal" ["register"]++ savePreviousResult pb Build pident True++ -- Even if the tests later fail, we can allow other libraries to build+ -- on top of our successful results+ --+ -- FIXME do we need to wait to do this until after Haddocks build?+ -- otherwise, we could have a race condition and try to build a+ -- dependency's haddocks before this finishes+ atomically $ putTMVar (piResult sbPackageInfo) True++ prevHaddockResult <- getPreviousResult pb Haddock pident+ let needHaddock = pbEnableHaddock+ && checkPrevResult prevHaddockResult pcHaddocks+ && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)+ when needHaddock $ withConfiged $ do+ log' $ "Haddocks " ++ namever+ hfs <- readTVarIO sbHaddockFiles+ let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat+ [ "--haddock-options=--read-interface="+ , "../"+ , pkgVer+ , "/,"+ , fpToText hf+ ]+ args = ($ hfsOpts) $ execWriter $ do+ let tell' x = tell (x:)+ tell' "haddock"+ tell' "--hyperlink-source"+ tell' "--html"+ when pbBuildHoogle $ tell' "--hoogle"+ tell' "--html-location=../$pkg-$version/"++ eres <- tryAny $ run "cabal" args++ forM_ eres $ \() -> do+ renameOrCopy+ (childDir </> "dist" </> "doc" </> "html" </> fpFromText name)+ (pbDocDir pb </> fpFromText namever)++ enewPath <- tryIO+ $ canonicalizePath+ $ pbDocDir pb+ </> fpFromText namever+ </> fpFromText name <.> "haddock"+ case enewPath of+ Left e -> warn $ tshow e+ Right newPath -> atomically+ $ modifyTVar sbHaddockFiles+ $ insertMap namever newPath++ savePreviousResult pb Haddock pident $ either (const False) (const True) eres+ case (eres, pcHaddocks) of+ (Left e, ExpectSuccess) -> throwM e+ (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"+ _ -> return ()++ return withUnpacked++ runTests withUnpacked = wf testOut $ \getOutH -> do+ let run = runChild getOutH++ prevTestResult <- getPreviousResult pb Test pident+ let needTest = pbEnableTests+ && checkPrevResult prevTestResult pcTests+ when needTest $ withUnpacked $ do+ log' $ "Test configure " ++ namever+ run "cabal" $ "configure" : "--enable-tests" : configArgs++ eres <- tryAny $ do+ log' $ "Test build " ++ namever+ run "cabal" ["build"]++ log' $ "Test run " ++ namever+ run "cabal" ["test", "--log=" ++ fpToText testRunOut]++ savePreviousResult pb Test pident $ either (const False) (const True) eres+ case (eres, pcTests) of+ (Left e, ExpectSuccess) -> throwM e+ (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"+ _ -> return ()++ warn t = atomically $ modifyTVar sbWarningsVar (. (t:))++ updateErrs exc = do+ log' $ concat+ [ display (piName sbPackageInfo)+ , ": "+ , tshow exc+ ]+ atomically $ modifyTVar sbErrsVar $ insertMap (piName sbPackageInfo) exc'+ where+ exc' =+ case fromException exc of+ Just bf -> bf+ Nothing -> BuildFailureException exc++renameOrCopy :: FilePath -> FilePath -> IO ()+renameOrCopy src dest = rename src dest `catchIO` \_ -> copyDir src dest++copyBuiltInHaddocks :: FilePath -> IO ()+copyBuiltInHaddocks docdir = do+ mghc <- findExecutable "ghc"+ case mghc of+ Nothing -> error "GHC not found on PATH"+ Just ghc -> do+ src <- canonicalizePath+ (parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")+ copyDir src docdir++------------- Previous results++-- | The previous actions that can be run+data ResultType = Build | Haddock | Test+ deriving (Show, Enum, Eq, Ord, Bounded, Read)++-- | The result generated on a previous run+data PrevResult = PRNoResult | PRSuccess | PRFailure+ deriving (Show, Enum, Eq, Ord, Bounded, Read)++-- | Check if we should rerun based on a PrevResult and the expected status+checkPrevResult :: PrevResult -> TestState -> Bool+checkPrevResult _ Don'tBuild = False+checkPrevResult PRNoResult _ = True+checkPrevResult PRSuccess _ = False+checkPrevResult PRFailure ExpectSuccess = True+checkPrevResult PRFailure _ = False++withPRPath :: PerformBuild -> ResultType -> PackageIdentifier -> (FilePath -> IO a) -> IO a+withPRPath pb rt ident inner = do+ createTree $ parent fp+ inner fp+ where+ fp = pbPrevResDir pb </> fpFromString (show rt) </> fpFromText (display ident)++successBS, failureBS :: ByteString+successBS = "success"+failureBS = "failure"++getPreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> IO PrevResult+getPreviousResult w x y = withPRPath w x y $ \fp -> do+ eres <- tryIO $ readFile fp+ return $ case eres of+ Right bs+ | bs == successBS -> PRSuccess+ | bs == failureBS -> PRFailure+ _ -> PRNoResult++savePreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> Bool -> IO ()+savePreviousResult pb rt ident res =+ withPRPath pb rt ident $ \fp -> writeFile fp $+ if res then successBS else failureBS++deletePreviousResults :: PerformBuild -> PackageIdentifier -> IO ()+deletePreviousResults pb name =+ forM_ [minBound..maxBound] $ \rt ->+ withPRPath pb rt name $ \fp ->+ void $ tryIO $ removeFile fp
+ Stackage/Prelude.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+module Stackage.Prelude+ ( module X+ , module Stackage.Prelude+ ) where++import ClassyPrelude.Conduit as X+import Data.Aeson (FromJSON, ToJSON)+import Data.Conduit.Process as X+import qualified Data.Map as Map+import Data.Typeable (TypeRep, typeOf)+import Distribution.Package as X (PackageIdentifier (..), PackageName (PackageName))+import Distribution.PackageDescription as X (FlagName (..), GenericPackageDescription)+import qualified Distribution.Text as DT+import Distribution.Version as X (Version (..),+ VersionRange)+import Distribution.Version as X (withinRange)+import qualified Distribution.Version as C+import Filesystem (createTree)+import Filesystem.Path (parent)+import qualified Filesystem.Path as F++unPackageName :: PackageName -> Text+unPackageName (PackageName str) = pack str++unFlagName :: FlagName -> Text+unFlagName (FlagName str) = pack str++mkPackageName :: Text -> PackageName+mkPackageName = PackageName . unpack++mkFlagName :: Text -> FlagName+mkFlagName = FlagName . unpack++display :: DT.Text a => a -> Text+display = fromString . DT.display++simpleParse :: (MonadThrow m, DT.Text a, Typeable a) => Text -> m a+simpleParse orig = withTypeRep $ \rep ->+ case DT.simpleParse str of+ Nothing -> throwM (ParseFailedException rep (pack str))+ Just v -> return v+ where+ str = unpack orig++ withTypeRep :: Typeable a => (TypeRep -> m a) -> m a+ withTypeRep f =+ res+ where+ res = f (typeOf (unwrap res))++ unwrap :: m a -> a+ unwrap _ = error "unwrap"++data ParseFailedException = ParseFailedException TypeRep Text+ deriving (Show, Typeable)+instance Exception ParseFailedException++newtype Maintainer = Maintainer { unMaintainer :: Text }+ deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString)++-- | Name of an executable.+newtype ExeName = ExeName { unExeName :: Text }+ deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString)++intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange+intersectVersionRanges x y = C.simplifyVersionRange $ C.intersectVersionRanges x y++-- | There seems to be a bug in Cabal where serializing and deserializing+-- version ranges winds up with different representations. So we have a+-- super-simplifier to deal with that.+simplifyVersionRange :: VersionRange -> VersionRange+simplifyVersionRange vr =+ fromMaybe (assert False vr') $ simpleParse $ display vr'+ where+ vr' = C.simplifyVersionRange vr++-- | Topologically sort so that items with dependencies occur after those+-- dependencies.+topologicalSort :: (Ord key, Show key, MonadThrow m, Typeable key)+ => (value -> finalValue)+ -> (value -> Set key) -- ^ deps+ -> Map key value+ -> m (Vector (key, finalValue))+topologicalSort toFinal toDeps =+ loop id . mapWithKey removeSelfDeps . fmap (toDeps &&& toFinal)+ where+ removeSelfDeps k (deps, final) = (deleteSet k deps, final)+ loop front toProcess | null toProcess = return $ pack $ front []+ loop front toProcess+ | null noDeps = throwM $ NoEmptyDeps (map fst toProcess')+ | otherwise = loop (front . noDeps') (mapFromList hasDeps)+ where+ toProcess' = fmap (first removeUnavailable) toProcess+ allKeys = Map.keysSet toProcess+ removeUnavailable = asSet . setFromList . filter (`member` allKeys) . setToList+ (noDeps, hasDeps) = partition (null . fst . snd) $ mapToList toProcess'+ noDeps' = (map (second snd) noDeps ++)++data TopologicalSortException key = NoEmptyDeps (Map key (Set key))+ deriving (Show, Typeable)+instance (Show key, Typeable key) => Exception (TopologicalSortException key)++copyDir :: FilePath -> FilePath -> IO ()+copyDir src dest =+ runResourceT $ sourceDirectoryDeep False src $$ mapM_C go+ where+ src' = src </> ""+ go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do+ let dest' = dest </> suffix+ liftIO $ createTree $ parent dest'+ sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
+ Stackage/ServerBundle.hs view
@@ -0,0 +1,271 @@+-- | Create a bundle to be uploaded to Stackage Server.+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Stackage.ServerBundle+ ( serverBundle+ , epochTime+ , bpAllPackages+ , docsListing+ , createBundleV2+ , CreateBundleV2 (..)+ , SnapshotType (..)+ , writeIndexStyle+ , DocMap+ , PackageDocs (..)+ ) where++import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Codec.Compression.GZip as GZip+import qualified Data.Map as M+import Data.Aeson (ToJSON (..), (.=), object, FromJSON (..), (.:), withObject)+import System.IO.Temp (withTempDirectory)+import qualified Data.Yaml as Y+import Filesystem (isFile, getWorkingDirectory, listDirectory, isDirectory, canonicalizePath)+import Foreign.C.Types (CTime (CTime))+import Stackage.BuildConstraints+import Stackage.BuildPlan+import Stackage.Prelude+import System.IO.Temp (withTempDirectory)+import qualified System.PosixCompat.Time as PC+import qualified Text.XML as X+import Text.XML.Cursor+import System.PosixCompat.Files (createSymbolicLink)++-- | Get current time+epochTime :: IO Tar.EpochTime+epochTime = (\(CTime t) -> fromIntegral t) <$> PC.epochTime++-- | All package/versions in a build plan, including core packages.+--+-- Note that this may include packages not available on Hackage.+bpAllPackages :: BuildPlan -> Map PackageName Version+bpAllPackages BuildPlan {..} =+ siCorePackages bpSystemInfo ++ map ppVersion bpPackages++serverBundle :: Tar.EpochTime+ -> Text -- ^ title+ -> Text -- ^ slug+ -> BuildPlan+ -> LByteString+serverBundle time title slug bp@BuildPlan {..} = GZip.compress $ Tar.write+ [ fe "build-plan.yaml" (fromStrict $ Y.encode bp)+ , fe "hackage" hackage+ , fe "slug" (fromStrict $ encodeUtf8 slug)+ , fe "desc" (fromStrict $ encodeUtf8 title)+ , fe "core" corePackagesList+ ]+ where+ fe name contents =+ case Tar.toTarPath False name of+ Left s -> error s+ Right name' -> (Tar.fileEntry name' contents)+ { Tar.entryTime = time+ }+ hackage = builderToLazy $ foldMap goPair $ mapToList packageMap++ -- need to remove some packages that don't exist on Hackage+ packageMap = foldr deleteMap (bpAllPackages bp) $ map PackageName+ [ "bin-package-db"+ , "ghc"+ , "rts"+ ]++ goPair (name, version) =+ toBuilder (display name) +++ toBuilder (asText "-") +++ toBuilder (display version) +++ toBuilder (asText "\n")++ corePackagesList =+ builderToLazy $ toBuilder $ unlines $+ map (\(PackageName name) -> name)+ (M.keys $ siCorePackages bpSystemInfo)++-- | Package name is key+type DocMap = Map Text PackageDocs+data PackageDocs = PackageDocs+ { pdVersion :: Text+ , pdModules :: Map Text [Text]+ -- ^ module name, path+ }+instance ToJSON PackageDocs where+ toJSON PackageDocs {..} = object+ [ "version" .= pdVersion+ , "modules" .= pdModules+ ]+instance FromJSON PackageDocs where+ parseJSON = withObject "PackageDocs" $ \o -> PackageDocs+ <$> o .: "version"+ <*> o .: "modules"++docsListing :: BuildPlan+ -> FilePath -- ^ docs directory+ -> IO DocMap+docsListing bp docsDir =+ fmap fold $ mapM go $ mapToList $ bpAllPackages bp+ where+ go :: (PackageName, Version) -> IO DocMap+ go (package, version) = do -- handleAny (const $ return mempty) $ do+ let dirname = fpFromText (concat+ [ display package+ , "-"+ , display version+ ])+ indexFP = (docsDir </> dirname </> "index.html")+ ie <- isFile indexFP+ if ie+ then do+ doc <- flip X.readFile indexFP X.def+ { X.psDecodeEntities = X.decodeHtmlEntities+ }+ let cursor = fromDocument doc+ getPair x = take 1 $ do+ href <- attribute "href" x+ let name = concat $ x $// content+ guard $ not $ null name+ return (href, name)+ pairs = cursor $// attributeIs "class" "module"+ &/ laxElement "a" >=> getPair+ m <- fmap fold $ forM pairs $ \(href, name) -> do+ let suffix = dirname </> fpFromText href+ e <- isFile $ docsDir </> suffix+ return $ if e+ then asMap $ singletonMap name [fpToText dirname, href]+ else mempty+ return $ singletonMap (display package) $ PackageDocs+ { pdVersion = display version+ , pdModules = m+ }+ else return mempty++data SnapshotType = STNightly+ | STLTS !Int !Int -- ^ major, minor+ deriving (Show, Read, Eq, Ord)++instance ToJSON SnapshotType where+ toJSON STNightly = object+ [ "type" .= asText "nightly"+ ]+ toJSON (STLTS major minor) = object+ [ "type" .= asText "lts"+ , "major" .= major+ , "minor" .= minor+ ]+instance FromJSON SnapshotType where+ parseJSON = withObject "SnapshotType" $ \o -> do+ t <- o .: "type"+ case asText t of+ "nightly" -> return STNightly+ "lts" -> STLTS+ <$> o .: "major"+ <*> o .: "minor"+ _ -> fail $ "Unknown type for SnapshotType: " ++ unpack t++data CreateBundleV2 = CreateBundleV2+ { cb2Plan :: BuildPlan+ , cb2Type :: SnapshotType+ , cb2DocsDir :: FilePath+ , cb2Dest :: FilePath+ }++-- | Create a V2 bundle, which contains the build plan, metadata, docs, and doc+-- map.+createBundleV2 :: CreateBundleV2 -> IO ()+createBundleV2 CreateBundleV2 {..} = do+ docsDir <- canonicalizePath cb2DocsDir+ docMap <- docsListing cb2Plan cb2DocsDir++ Y.encodeFile (fpToString $ docsDir </> "build-plan.yaml") cb2Plan+ Y.encodeFile (fpToString $ docsDir </> "build-type.yaml") cb2Type+ Y.encodeFile (fpToString $ docsDir </> "docs-map.yaml") docMap+ void $ writeIndexStyle Nothing cb2DocsDir++ currentDir <- getWorkingDirectory+ files <- listDirectory docsDir++ let args = "cfJ"+ : fpToString (currentDir </> cb2Dest)+ : "--dereference"+ : map (fpToString . filename) files+ cp = (proc "tar" args) { cwd = Just $ fpToString docsDir }+ withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return ()++writeIndexStyle :: Maybe Text -- ^ snapshot id+ -> FilePath -- ^ docs dir+ -> IO [String]+writeIndexStyle msnapid dir = do+ dirs <- fmap sort+ $ runResourceT+ $ sourceDirectory dir+ $$ filterMC (liftIO . isDirectory)+ =$ mapC (fpToString . filename)+ =$ sinkList+ writeFile (dir </> "index.html") $ mkIndex+ (unpack <$> msnapid)+ dirs+ writeFile (dir </> "style.css") styleCss+ return dirs++mkIndex :: Maybe String -> [String] -> String+mkIndex msnapid dirs = concat+ [ "<!DOCTYPE html>\n<html lang='en'><head><title>Haddocks index</title>"+ , "<link rel='stylesheet' href='https://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css'>"+ , "<link rel='stylesheet' href='style.css'>"+ , "<link rel='shortcut icon' href='http://www.stackage.org/static/img/favicon.ico' />"+ , "</head>"+ , "<body><div class='container'>"+ , "<div class='row'><div class='span12 col-md-12'>"+ , "<h1>Haddock documentation index</h1>"+ , flip foldMap msnapid $ \snapid -> concat+ [ "<p class='return'><a href=\"http://www.stackage.org/stackage/"+ , snapid+ , "\">Return to snapshot</a></p>"+ ]+ , "<ul>"+ , concatMap toLI dirs+ , "</ul></div></div></div></body></html>"+ ]+ where+ toLI name = concat+ [ "<li><a href='"+ , name+ , "/index.html'>"+ , name+ , "</a></li>"+ ]++styleCss :: String+styleCss = concat+ [ "@media (min-width: 530px) {"+ , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }"+ , "}"+ , "@media (min-width: 760px) {"+ , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }"+ , "}"+ , "ul {"+ , " margin-left: 0;"+ , " padding-left: 0;"+ , " list-style-type: none;"+ , "}"+ , "body {"+ , " background: #f0f0f0;"+ , " font-family: 'Lato', sans-serif;"+ , " text-shadow: 1px 1px 1px #ffffff;"+ , " font-size: 20px;"+ , " line-height: 30px;"+ , " padding-bottom: 5em;"+ , "}"+ , "h1 {"+ , " font-weight: normal;"+ , " color: #06537d;"+ , " font-size: 45px;"+ , "}"+ , ".return a {"+ , " color: #06537d;"+ , " font-style: italic;"+ , "}"+ , ".return {"+ , " margin-bottom: 1em;"+ , "}"]
+ Stackage/UpdateBuildPlan.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+-- | Take an existing build plan and bump all packages to the newest version in+-- the same major version number.+module Stackage.UpdateBuildPlan+ ( updateBuildConstraints+ , updateBuildPlan+ ) where++import qualified Data.Map as Map+import Distribution.Version (anyVersion, earlierVersion,+ orLaterVersion)+import Stackage.BuildConstraints+import Stackage.BuildPlan+import Stackage.Prelude++updateBuildPlan :: Map PackageName PackagePlan -> BuildPlan -> IO BuildPlan+updateBuildPlan packagesOrig+ = newBuildPlan packagesOrig . updateBuildConstraints++updateBuildConstraints :: BuildPlan -> BuildConstraints+updateBuildConstraints BuildPlan {..} =+ BuildConstraints {..}+ where+ bcSystemInfo = bpSystemInfo+ bcPackages = Map.keysSet bpPackages+ bcGithubUsers = bpGithubUsers++ bcPackageConstraints name = PackageConstraints+ { pcVersionRange = addBumpRange (maybe anyVersion pcVersionRange moldPC)+ , pcMaintainer = moldPC >>= pcMaintainer+ , pcTests = maybe ExpectSuccess pcTests moldPC+ , pcHaddocks = maybe ExpectSuccess pcHaddocks moldPC+ , pcBuildBenchmarks = maybe True pcBuildBenchmarks moldPC+ , pcFlagOverrides = maybe mempty pcFlagOverrides moldPC+ , pcEnableLibProfile = maybe False pcEnableLibProfile moldPC+ }+ where+ moldBP = lookup name bpPackages+ moldPC = ppConstraints <$> moldBP++ addBumpRange oldRange =+ case moldBP of+ Nothing -> oldRange+ Just bp -> intersectVersionRanges oldRange+ $ bumpRange $ ppVersion bp++ bumpRange version = intersectVersionRanges+ (orLaterVersion version)+ (earlierVersion $ bumpVersion version)+ bumpVersion (Version (x:y:_) _) = Version [x, y + 1] []+ bumpVersion (Version [x] _) = Version [x, 1] []+ bumpVersion (Version [] _) = assert False $ Version [1, 0] []
+ Stackage/Upload.hs view
@@ -0,0 +1,272 @@+-- | Upload to Stackage and Hackage+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+module Stackage.Upload+ ( UploadBundle (..)+ , SnapshotIdent (..)+ , uploadBundle+ , UploadDocs (..)+ , uploadDocs+ , uploadHackageDistro+ , uploadHackageDistroNamed+ , UploadDocMap (..)+ , uploadDocMap+ , uploadBundleV2+ , UploadBundleV2 (..)+ , def+ , StackageServer+ , unStackageServer+ ) where++import Control.Monad.Writer.Strict (execWriter, tell)+import Data.Default.Class (Default (..))+import Data.Function (fix)+import Filesystem (isDirectory, isFile)+import Network.HTTP.Client+import qualified Network.HTTP.Client.Conduit as HCC+import Network.HTTP.Client.MultipartFormData+import Stackage.BuildPlan (BuildPlan)+import Stackage.Prelude+import Stackage.ServerBundle (bpAllPackages, docsListing, writeIndexStyle)+import System.IO.Temp (withSystemTempFile)+import qualified System.IO as IO+import qualified Data.Yaml as Y++newtype StackageServer = StackageServer { unStackageServer :: Text }+ deriving (Show, Eq, Ord, Hashable, IsString)+instance Default StackageServer where+ def = "http://www.stackage.org"++data UploadBundle = UploadBundle+ { ubServer :: StackageServer+ , ubContents :: LByteString+ , ubAlias :: Maybe Text+ , ubNightly :: Maybe Text -- ^ should be GHC version+ , ubLTS :: Maybe Text -- ^ e.g. 2.3+ , ubAuthToken :: Text+ }+instance Default UploadBundle where+ def = UploadBundle+ { ubServer = def+ , ubContents = mempty+ , ubAlias = Nothing+ , ubNightly = Nothing+ , ubLTS = Nothing+ , ubAuthToken = "no-auth-token-provided"+ }++newtype SnapshotIdent = SnapshotIdent { unSnapshotIdent :: Text }+ deriving (Show, Eq, Ord, Hashable, IsString)++uploadBundle :: UploadBundle -> Manager -> IO (SnapshotIdent, Maybe Text)+uploadBundle UploadBundle {..} man = do+ req1 <- parseUrl $ unpack $ unStackageServer ubServer ++ "/upload"+ req2 <- formDataBody formData req1+ let req3 = req2+ { method = "PUT"+ , requestHeaders =+ [ ("Authorization", encodeUtf8 ubAuthToken)+ , ("Accept", "application/json")+ ] ++ requestHeaders req2+ , redirectCount = 0+ , checkStatus = \_ _ _ -> Nothing+ , responseTimeout = Just 300000000+ }+ res <- httpLbs req3 man+ case lookup "x-stackage-ident" $ responseHeaders res of+ Just snapid -> return+ ( SnapshotIdent $ decodeUtf8 snapid+ , decodeUtf8 <$> lookup "location" (responseHeaders res)+ )+ Nothing -> error $ "An error occurred: " ++ show res+ where+ params = mapMaybe (\(x, y) -> (x, ) <$> y)+ [ ("alias", ubAlias)+ , ("nightly", ubNightly)+ , ("lts", ubLTS)+ ]+ formData = ($ []) $ execWriter $ do+ forM_ params $ \(key, value) ->+ tell' $ partBS key $ encodeUtf8 value+ tell' $ partFileRequestBody "stackage" "stackage"+ $ RequestBodyLBS ubContents++ tell' x = tell (x:)++data UploadDocs = UploadDocs+ { udServer :: StackageServer+ , udDocs :: FilePath -- ^ may be a directory or a tarball+ , udAuthToken :: Text+ , udSnapshot :: SnapshotIdent+ }++uploadDocs :: UploadDocs -> Manager -> IO (Response LByteString)+uploadDocs (UploadDocs (StackageServer host) fp0 token ident) man = do+ fe <- isFile fp0+ if fe+ then uploadDocsFile $ fpToString fp0+ else do+ de <- isDirectory fp0+ if de+ then uploadDocsDir+ else error $ "Path not found: " ++ fpToString fp0+ where+ uploadDocsDir = withSystemTempFile "haddocks.tar.xz" $ \fp h -> do+ hClose h+ dirs <- writeIndexStyle (Just $ unSnapshotIdent ident) fp0+ let cp = (proc "tar" $ "cJf" : fp : "index.html" : "style.css" : dirs)+ { cwd = Just $ fpToString fp0+ }+ withCheckedProcess cp $ \Inherited Inherited Inherited -> return ()+ uploadDocsFile fp+ uploadDocsFile fp = do+ req1 <- parseUrl $ unpack $ concat+ [ host+ , "/upload-haddock/"+ , unSnapshotIdent ident+ ]+ let formData =+ [ partFileSource "tarball" fp+ ]+ req2 <- formDataBody formData req1+ let req3 = req2+ { method = "PUT"+ , requestHeaders =+ [ ("Authorization", encodeUtf8 token)+ , ("Accept", "application/json")+ ] ++ requestHeaders req2+ , redirectCount = 0+ , checkStatus = \_ _ _ -> Nothing+ , responseTimeout = Just 300000000+ }+ httpLbs req3 man++uploadHackageDistro :: BuildPlan+ -> ByteString -- ^ Hackage username+ -> ByteString -- ^ Hackage password+ -> Manager+ -> IO (Response LByteString)+uploadHackageDistro = uploadHackageDistroNamed "Stackage"++uploadHackageDistroNamed+ :: Text -- ^ distro name+ -> BuildPlan+ -> ByteString -- ^ Hackage username+ -> ByteString -- ^ Hackage password+ -> Manager+ -> IO (Response LByteString)+uploadHackageDistroNamed name bp username password manager = do+ req1 <- parseUrl $ concat+ [ "http://hackage.haskell.org/distro/"+ , unpack name+ , "/packages.csv"+ ]+ let req2 = req1+ { requestHeaders = [("Content-Type", "text/csv")]+ , requestBody = RequestBodyLBS csv+ , checkStatus = \_ _ _ -> Nothing+ , method = "PUT"+ }+ httpLbs (applyBasicAuth username password req2) manager+ where+ csv = encodeUtf8+ $ builderToLazy+ $ mconcat+ $ intersperse "\n"+ $ map go+ $ mapToList+ $ bpAllPackages bp+ go (name, version) =+ "\"" +++ (toBuilder $ display name) +++ "\",\"" +++ (toBuilder $ display version) +++ "\",\"http://www.stackage.org/package/" +++ (toBuilder $ display name) +++ "\""++data UploadDocMap = UploadDocMap+ { udmServer :: StackageServer+ , udmAuthToken :: Text+ , udmSnapshot :: SnapshotIdent+ , udmDocDir :: FilePath+ , udmPlan :: BuildPlan+ }++uploadDocMap :: UploadDocMap -> Manager -> IO (Response LByteString)+uploadDocMap UploadDocMap {..} man = do+ docmap <- docsListing udmPlan udmDocDir+ req1 <- parseUrl $ unpack $ unStackageServer udmServer ++ "/upload-doc-map"+ req2 <- formDataBody (formData $ Y.encode docmap) req1+ let req3 = req2+ { method = "PUT"+ , requestHeaders =+ [ ("Authorization", encodeUtf8 udmAuthToken)+ , ("Accept", "application/json")+ ] ++ requestHeaders req2+ , redirectCount = 0+ , checkStatus = \_ _ _ -> Nothing+ , responseTimeout = Just 300000000+ }+ httpLbs req3 man+ where+ formData docmap =+ [ partBS "snapshot" (encodeUtf8 $ unSnapshotIdent udmSnapshot)+ , partFileRequestBody "docmap" "docmap" $ RequestBodyBS docmap+ ]++data UploadBundleV2 = UploadBundleV2+ { ub2Server :: StackageServer+ , ub2AuthToken :: Text+ , ub2Bundle :: FilePath+ }++uploadBundleV2 :: UploadBundleV2 -> Manager -> IO Text+uploadBundleV2 UploadBundleV2 {..} man = IO.withBinaryFile (fpToString ub2Bundle) IO.ReadMode $ \h -> do+ size <- IO.hFileSize h+ putStrLn $ "Bundle size: " ++ tshow size+ req1 <- parseUrl $ unpack $ unStackageServer ub2Server ++ "/upload2"+ let req2 = req1+ { method = "PUT"+ , requestHeaders =+ [ ("Authorization", encodeUtf8 ub2AuthToken)+ , ("Accept", "application/json")+ , ("Content-Type", "application/x-tar")+ ]+ , requestBody = HCC.requestBodySource (fromIntegral size)+ $ sourceHandle h $= printProgress size+ }+ sink = decodeUtf8C =$ fix (\loop -> do+ mx <- peekC+ case mx of+ Nothing -> error $ "uploadBundleV2: premature end of stream"+ Just _ -> do+ l <- lineC $ takeCE 4096 =$ foldC+ let (cmd, msg') = break (== ':') l+ msg = dropWhile (== ' ') $ dropWhile (== ':') msg'+ case cmd of+ "CONT" -> do+ putStrLn msg+ loop+ "FAILURE" -> error $ "uploadBundleV2 failed: " ++ unpack msg+ "SUCCESS" -> return msg+ _ -> error $ "uploadBundleV2: unknown command " ++ unpack cmd+ )+ withResponse req2 man $ \res -> HCC.bodyReaderSource (responseBody res) $$ sink+ where+ printProgress total =+ loop 0 0+ where+ loop sent lastPercent =+ await >>= maybe (putStrLn "Upload complete") go+ where+ go bs = do+ yield bs+ let sent' = sent + fromIntegral (length bs)+ percent = sent' * 100 `div` total+ when (percent /= lastPercent)+ $ putStrLn $ "Upload progress: " ++ tshow percent ++ "%"+ loop sent' percent
+ app/stackage.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE TupleSections #-}++module Main where++import Control.Monad+import Data.Monoid+import Data.String (fromString)+import Data.Version+import Options.Applicative+import Filesystem.Path.CurrentOS (decodeString)+import Paths_stackage (version)+import Stackage.CompleteBuild+import Stackage.Upload+import Stackage.InstallBuild+import Network.HTTP.Client (withManager)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import qualified Data.Text as T++main :: IO ()+main =+ join $+ execParser $+ info+ (helpOption <*> versionOption <*> config)+ (header "Stackage" <>+ fullDesc)+ where+ helpOption =+ abortOption ShowHelpText $+ long "help" <>+ help "Show this help text"+ versionOption =+ infoOption+ ("stackage version " ++ showVersion version)+ (long "version" <>+ help "Show stackage version")+ config =+ subparser $+ mconcat+ [ cmnd+ (uncurry completeBuild)+ (fmap (Nightly, ) buildFlags)+ "nightly"+ "Build, test and upload the Nightly snapshot"+ , cmnd+ (uncurry completeBuild)+ (fmap (LTS Major, ) buildFlags)+ "lts-major"+ "Build, test and upload the LTS (major) snapshot"+ , cmnd+ (uncurry completeBuild)+ (fmap (LTS Minor, ) buildFlags)+ "lts-minor"+ "Build, test and upload the LTS (minor) snapshot"+ , cmnd+ justUploadNightly+ nightlyUploadFlags+ "upload-nightly"+ "Upload an already-built nightly snapshot"+ , cmnd+ (const justCheck)+ (pure ())+ "check"+ "Just check that the build plan is ok"+ , cmnd+ installBuild+ installFlags+ "install"+ "Install a snapshot from an existing build plan"+ , cmnd+ uploadv2+ uploadv2Flags+ "upload2"+ "Upload a pre-existing v2 bundle"+ ]++ cmnd exec parse name desc =+ command name $+ info+ (fmap exec (parse <**> helpOption))+ (progDesc desc)++ buildFlags =+ BuildFlags <$>+ fmap+ not+ (switch+ (long "skip-tests" <>+ help "Skip build and running the test suites")) <*>+ fmap+ not+ (switch+ (long "skip-haddock" <>+ help "Skip generating haddock documentation")) <*>+ fmap+ not+ (switch+ (long "skip-upload" <>+ help "Skip uploading bundle, docs, etc.")) <*>+ switch+ (long "enable-library-profiling" <>+ help "Enable profiling when building") <*>+ switch+ (long "enable-executable-dynamic" <>+ help "Enable dynamic executables when building") <*>+ switch+ (long "verbose" <> short 'v' <>+ help "Output verbose detail about the build steps") <*>+ switch+ (long "skip-check" <>+ help "Skip the check phase, and pass --allow-newer to cabal configure") <*>+ switch+ (long "upload-v1" <>+ help "Use the V1 upload code") <*>+ (fmap fromString (strOption+ (long "server-url" <>+ metavar "SERVER-URL" <>+ showDefault <> value (T.unpack $ unStackageServer def) <>+ help "Server to upload bundle to"))) <*>+ fmap+ not+ (switch+ (long "skip-hoogle" <>+ help "Skip generating Hoogle input files"))++ nightlyUploadFlags = fromString <$> strArgument+ (metavar "DATE" <>+ help "Date, in YYYY-MM-DD format")++ installFlags =+ InstallFlags <$>+ (fmap+ BPSBundleWeb+ (strOption+ (long "bundle" <>+ metavar "URL" <>+ help "Stackage bundle containing build plan")) <|>+ fmap+ (BPSFile . decodeString)+ (strOption+ (long "build-plan" <>+ metavar "PATH" <>+ help "Build-plan YAML file"))) <*>+ fmap+ decodeString+ (strArgument+ (metavar "DESTINATION-PATH" <>+ help "Destination directory path")) <*>+ (fmap+ (Just . decodeString)+ (strOption+ (long "log-dir" <>+ metavar "PATH" <>+ help "Location of log files (default DESTINATION-PATH/logs)")) <|>+ pure Nothing) <*>+ option+ auto+ (long "jobs" <>+ metavar "NUMBER" <>+ showDefault <> value 8 <>+ help "Number of threads") <*>+ switch+ (long "global" <>+ help "Install in global package database") <*>+ fmap+ not+ (switch+ (long "skip-tests" <>+ help "Skip build and running the test suites")) <*>+ fmap+ not+ (switch+ (long "skip-haddock" <>+ help "Skip generating haddock documentation")) <*>+ switch+ (long "enable-library-profiling" <>+ help "Enable profiling when building") <*>+ switch+ (long "enable-executable-dynamic" <>+ help "Enable dynamic executables when building") <*>+ switch+ (long "verbose" <> short 'v' <>+ help "Output verbose detail about the build steps") <*>+ switch+ (long "skip-check" <>+ help "Skip the check phase, and pass --allow-newer to cabal configure") <*>+ fmap+ not+ (switch+ (long "skip-hoogle" <>+ help "Skip generating Hoogle input files"))++ uploadv2 (path, url) = withManager tlsManagerSettings $ \man -> do+ token <- getStackageAuthToken+ res <- flip uploadBundleV2 man UploadBundleV2+ { ub2AuthToken = token+ , ub2Server = fromString url+ , ub2Bundle = decodeString path+ }+ putStrLn $ "New URL: " ++ T.unpack res++ uploadv2Flags = (,)+ <$> (strArgument+ (metavar "BUNDLE-PATH" <>+ help "Bundle path"))+ <*> strOption+ (long "server-url" <>+ metavar "SERVER-URL" <>+ showDefault <> value (T.unpack $ unStackageServer def) <>+ help "Server to upload bundle to")
+ stackage-curator.cabal view
@@ -0,0 +1,105 @@+name: stackage-curator+version: 0.7.0+synopsis: Tools for curating Stackage bundles+description: Please see <http://www.stackage.org/package/stackage-curator> 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+ test/test-build-constraints.yaml++library+ default-language: Haskell2010+ exposed-modules: Stackage.Prelude+ Stackage.BuildConstraints+ Stackage.CorePackages+ Stackage.PackageIndex+ Stackage.BuildPlan+ Stackage.CheckBuildPlan+ Stackage.UpdateBuildPlan+ Stackage.GhcPkg+ Stackage.GithubPings+ Stackage.InstallBuild+ Stackage.PackageDescription+ Stackage.ServerBundle+ Stackage.Upload+ Stackage.PerformBuild+ Stackage.CompleteBuild+ build-depends: base >= 4 && < 5+ , containers+ , Cabal >= 1.14+ , tar >= 0.3+ , zlib+ , bytestring+ , directory+ , filepath+ , transformers+ , process+ , old-locale+ , time+ , utf8-string++ , conduit-extra+ , classy-prelude-conduit+ , text+ , system-fileio+ , system-filepath+ , mtl+ , aeson+ , yaml+ , unix-compat+ , http-client+ , http-conduit+ , http-client-tls+ , temporary+ , data-default-class+ , stm+ , mono-traversable+ , async+ , streaming-commons >= 0.1.7.1+ , semigroups+ , xml-conduit+ , conduit++executable stackage-curator+ default-language: Haskell2010+ hs-source-dirs: app+ main-is: stackage.hs+ build-depends: base+ , stackage+ , optparse-applicative >= 0.11+ , system-filepath+ , http-client+ , http-client-tls+ , text+ ghc-options: -rtsopts -threaded -with-rtsopts=-N++test-suite spec+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Stackage.CorePackagesSpec+ Stackage.PackageIndexSpec+ Stackage.BuildPlanSpec+ build-depends: base+ , stackage+ , hspec+ , QuickCheck+ , text+ , classy-prelude-conduit+ , Cabal+ , yaml+ , containers+ , http-client+ , http-client-tls++source-repository head+ type: git+ location: https://github.com/fpco/stackage
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Stackage/BuildPlanSpec.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}+module Stackage.BuildPlanSpec (spec) where++import qualified Data.Map as Map+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import Data.Yaml+import qualified Data.Yaml as Y+import Distribution.Version+import Network.HTTP.Client+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Stackage.BuildConstraints+import Stackage.BuildPlan+import Stackage.CheckBuildPlan+import Stackage.PackageDescription+import Stackage.Prelude+import Stackage.UpdateBuildPlan+import Test.Hspec++spec :: Spec+spec = do+ it "simple package set" $ check testBuildConstraints $ makePackageSet+ [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])])+ ,("bar", [0, 0, 0], [])]+ it "bad version range on depdendency fails" $ badBuildPlan $ makePackageSet+ [("foo", [0, 0, 0], [("bar", thisV [1, 1, 0])])+ ,("bar", [0, 0, 0], [])]+ it "nonexistent package fails to check" $ badBuildPlan $ makePackageSet+ [("foo", [0, 0, 0], [("nonexistent", thisV [0, 0, 0])])+ ,("bar", [0, 0, 0], [])]+ it "mutual cycles fail to check" $ badBuildPlan $ makePackageSet+ [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])])+ ,("bar", [0, 0, 0], [("foo", thisV [0, 0, 0])])]+ it "nested cycles fail to check" $ badBuildPlan $ makePackageSet+ [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])])+ ,("bar", [0, 0, 0], [("mu", thisV [0, 0, 0])])+ ,("mu", [0, 0, 0], [("foo", thisV [0, 0, 0])])]+ {- Shouldn't be testing this actually+ it "default package set checks ok" $+ check defaultBuildConstraints getLatestAllowedPlans+ -}++-- | Checking should be considered a bad build plan.+badBuildPlan :: (BuildConstraints -> IO (Map PackageName PackagePlan))+ -> void+ -> IO ()+badBuildPlan m _ = do+ mu <- try (check testBuildConstraints m)+ case mu of+ Left (_ :: BadBuildPlan) ->+ return ()+ Right () ->+ error "Expected bad build plan."++-- | Check build plan with the given package set getter.+check :: (Manager -> IO BuildConstraints)+ -> (BuildConstraints -> IO (Map PackageName PackagePlan))+ -> IO ()+check readPlanFile getPlans = withManager tlsManagerSettings $ \man -> do+ bc <- readPlanFile man+ plans <- getPlans bc+ bp <- newBuildPlan plans bc+ let bs = Y.encode bp+ ebp' = Y.decodeEither bs++ bp' <- either error return ebp'++ let allPackages = Map.keysSet (bpPackages bp) ++ Map.keysSet (bpPackages bp')+ forM_ allPackages $ \name ->+ (name, lookup name (bpPackages bp')) `shouldBe`+ (name, lookup name (bpPackages bp))+ bpGithubUsers bp' `shouldBe` bpGithubUsers bp++ when (bp' /= bp) $ error "bp' /= bp"+ bp2 <- updateBuildPlan plans bp+ when (dropVersionRanges bp2 /= dropVersionRanges bp) $ error "bp2 /= bp"+ checkBuildPlan bp+ where+ dropVersionRanges bp =+ bp { bpPackages = map go $ bpPackages bp }+ where+ go pb = pb { ppConstraints = go' $ ppConstraints pb }+ go' pc = pc { pcVersionRange = anyVersion }++-- | Make a package set from a convenient data structure.+makePackageSet+ :: [(String,[Int],[(String,VersionRange)])]+ -> BuildConstraints+ -> IO (Map PackageName PackagePlan)+makePackageSet ps _ =+ return $+ M.fromList $+ map+ (\(name,ver,deps) ->+ ( PackageName name+ , dummyPackage ver $+ M.fromList $+ map+ (\(dname,dver) ->+ ( PackageName dname+ , DepInfo {diComponents = S.fromList+ [CompLibrary]+ ,diRange = dver}))+ deps))+ ps+ where+ dummyPackage v deps =+ PackagePlan+ {ppVersion = Version v []+ ,ppGithubPings = mempty+ ,ppUsers = mempty+ ,ppConstraints =+ PackageConstraints+ {pcVersionRange = anyV+ ,pcMaintainer = Nothing+ ,pcTests = Don'tBuild+ ,pcHaddocks = Don'tBuild+ ,pcBuildBenchmarks = False+ ,pcFlagOverrides = mempty+ ,pcEnableLibProfile = False}+ ,ppDesc =+ SimpleDesc+ {sdPackages = deps+ ,sdTools = mempty+ ,sdProvidedExes = mempty+ ,sdModules = mempty}}++-- | This exact version is required.+thisV :: [Int] -> VersionRange+thisV ver = thisVersion (Version ver [])++-- | Accept any version.+anyV :: VersionRange+anyV = anyVersion++-- | Test plan.+testBuildConstraints :: void -> IO BuildConstraints+testBuildConstraints _ =+ decodeFileEither+ (fpToString fp) >>=+ either throwIO toBC+ where fp = "test/test-build-constraints.yaml"
+ test/Stackage/CorePackagesSpec.hs 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
+ test/test-build-constraints.yaml view
@@ -0,0 +1,20 @@+packages:+ "Test":+ - foo+ - bar++global-flags: []++skipped-tests: []+expected-test-failures: []+expected-haddock-failures: []+skipped-benchmarks: []+skipped-profiling: []++github-users:+ bar:+ - demo++package-flags:+ foo:+ demo: true