diff --git a/.gitignore b/.gitignore index a153cdeb..6b60ace9 100644 --- a/.gitignore +++ b/.gitignore @@ -1,13 +1,4 @@ -dist -*.o -*.hi -*.chi -*.chs.h -*.swp /builds/ /logs/ -/.cabal-sandbox/ -cabal.sandbox.config nightly-*.yaml lts-*.yaml -/tarballs/ diff --git a/ChangeLog.md b/ChangeLog.md deleted file mode 100644 index d168d7e0..00000000 --- a/ChangeLog.md +++ /dev/null @@ -1,64 +0,0 @@ -## 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. diff --git a/Dockerfile b/Dockerfile deleted file mode 100644 index c3956908..00000000 --- a/Dockerfile +++ /dev/null @@ -1,25 +0,0 @@ -FROM ubuntu:12.04 - -ENV HOME /home/stackage -ENV LANG en_US.UTF-8 - -RUN mkdir /home/stackage -p -RUN locale-gen en_US.UTF-8 - -RUN DEBIAN_FRONTEND=noninteractive apt-get update -RUN DEBIAN_FRONTEND=noninteractive apt-get install -y software-properties-common python-software-properties -RUN DEBIAN_FRONTEND=noninteractive add-apt-repository ppa:hvr/ghc -y - -ADD debian-bootstrap.sh /tmp/debian-bootstrap.sh -RUN DEBIAN_FRONTEND=noninteractive bash /tmp/debian-bootstrap.sh -RUN rm /tmp/debian-bootstrap.sh - -RUN DEBIAN_FRONTEND=noninteractive apt-get install -y cabal-install-1.20 ghc-7.8.4 alex-3.1.3 happy-1.19.4 - -ENV PATH /home/stackage/.cabal/bin:/usr/local/sbin:/usr/local/bin:/opt/ghc/7.8.4/bin:/opt/cabal/1.20/bin:/opt/alex/3.1.3/bin:/opt/happy/1.19.4/bin:/usr/sbin:/usr/bin:/sbin:/bin - -RUN cabal update -ADD . /tmp/stackage -RUN cd /tmp/stackage && cabal install . hscolour cabal-install --constraint "Cabal < 1.22" && cp $HOME/.cabal/bin/* /usr/local/bin && rm -rf $HOME/.cabal $HOME/.ghc /tmp/stackage - -RUN cd /home/stackage && cabal update && stackage check diff --git a/README.md b/README.md index 82a9802d..848c9744 100644 --- a/README.md +++ b/README.md @@ -7,10 +7,14 @@ __NOTE__ This repository is for package authors to get their code into Stackage. If you simply want to use Stackage as an end user, please follow the instructions on [http://www.stackage.org/](http://www.stackage.org). -A note about the codebase: the goal is to minimize dependencies and have -the maximum range of supported compiler versions. Therefore, we avoid -anything "complicated." For example, instead of using the text package, -we use Strings everywhere. +The Stackage project consists of multiple repositories. This repository +contains the metadata on packages to be included in future builds and some +project information. In addition, we have the following repositories: + +* [stackage-server](https://github.com/fpco/stackage-server) +* [stackage-curator](https://github.com/fpco/stackage-curator) +* [stackage-types](https://github.com/fpco/stackage-types) +* [lts-haskell](https://github.com/fpco/lts-haskell) Get your package included ------------------------- diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 index 9a994af6..00000000 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs deleted file mode 100644 index c4ce1ceb..00000000 --- a/Stackage/BuildConstraints.hs +++ /dev/null @@ -1,234 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} --- | The constraints on package selection for a new build plan. -module Stackage.BuildConstraints - ( BuildConstraints (..) - , PackageConstraints (..) - , TestState (..) - , SystemInfo (..) - , getSystemInfo - , defaultBuildConstraints - , toBC - , BuildConstraintsSource (..) - , loadBuildConstraints - ) where - -import Control.Monad.Writer.Strict (execWriter, tell) -import Data.Aeson -import qualified Data.Map as Map -import Data.Yaml (decodeEither', decodeFileEither) -import Distribution.Package (Dependency (..)) -import Distribution.System (Arch, OS) -import qualified Distribution.System -import Distribution.Version (anyVersion) -import Filesystem (isFile) -import Network.HTTP.Client (Manager, httpLbs, responseBody, Request) -import Stackage.CorePackages -import Stackage.Prelude - -data TestState = ExpectSuccess - | ExpectFailure - | Don'tBuild -- ^ when the test suite will pull in things we don't want - deriving (Show, Eq, Ord, Bounded, Enum) - -testStateToText :: TestState -> Text -testStateToText ExpectSuccess = "expect-success" -testStateToText ExpectFailure = "expect-failure" -testStateToText Don'tBuild = "do-not-build" - -instance ToJSON TestState where - toJSON = toJSON . testStateToText -instance FromJSON TestState where - parseJSON = withText "TestState" $ \t -> - case lookup t states of - Nothing -> fail $ "Invalid state: " ++ unpack t - Just v -> return v - where - states = asHashMap $ mapFromList - $ map (\x -> (testStateToText x, x)) [minBound..maxBound] - -data SystemInfo = SystemInfo - { siGhcVersion :: Version - , siOS :: OS - , siArch :: Arch - , siCorePackages :: Map PackageName Version - , siCoreExecutables :: Set ExeName - } - deriving (Show, Eq, Ord) -instance ToJSON SystemInfo where - toJSON SystemInfo {..} = object - [ "ghc-version" .= display siGhcVersion - , "os" .= display siOS - , "arch" .= display siArch - , "core-packages" .= Map.mapKeysWith const unPackageName (map display siCorePackages) - , "core-executables" .= siCoreExecutables - ] -instance FromJSON SystemInfo where - parseJSON = withObject "SystemInfo" $ \o -> do - let helper name = (o .: name) >>= either (fail . show) return . simpleParse - siGhcVersion <- helper "ghc-version" - siOS <- helper "os" - siArch <- helper "arch" - siCorePackages <- (o .: "core-packages") >>= goPackages - siCoreExecutables <- o .: "core-executables" - return SystemInfo {..} - where - goPackages = either (fail . show) return - . mapM simpleParse - . Map.mapKeysWith const mkPackageName - -data BuildConstraints = BuildConstraints - { bcPackages :: Set PackageName - -- ^ This does not include core packages. - , bcPackageConstraints :: PackageName -> PackageConstraints - - , bcSystemInfo :: SystemInfo - - , bcGithubUsers :: Map Text (Set Text) - -- ^ map an account to set of pingees - } - -data PackageConstraints = PackageConstraints - { pcVersionRange :: VersionRange - , pcMaintainer :: Maybe Maintainer - , pcTests :: TestState - , pcHaddocks :: TestState - , pcBuildBenchmarks :: Bool - , pcFlagOverrides :: Map FlagName Bool - , pcEnableLibProfile :: Bool - } - deriving (Show, Eq) -instance ToJSON PackageConstraints where - toJSON PackageConstraints {..} = object $ addMaintainer - [ "version-range" .= display pcVersionRange - , "tests" .= pcTests - , "haddocks" .= pcHaddocks - , "build-benchmarks" .= pcBuildBenchmarks - , "flags" .= Map.mapKeysWith const unFlagName pcFlagOverrides - , "library-profiling" .= pcEnableLibProfile - ] - where - addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer -instance FromJSON PackageConstraints where - parseJSON = withObject "PackageConstraints" $ \o -> do - pcVersionRange <- (o .: "version-range") - >>= either (fail . show) return . simpleParse - pcTests <- o .: "tests" - pcHaddocks <- o .: "haddocks" - pcBuildBenchmarks <- o .: "build-benchmarks" - pcFlagOverrides <- Map.mapKeysWith const mkFlagName <$> o .: "flags" - pcMaintainer <- o .:? "maintainer" - pcEnableLibProfile <- fmap (fromMaybe True) (o .:? "library-profiling") - return PackageConstraints {..} - --- | The proposed plan from the requirements provided by contributors. --- --- Checks the current directory for a build-constraints.yaml file and uses it --- if present. If not, downloads from Github. -defaultBuildConstraints :: Manager -> IO BuildConstraints -defaultBuildConstraints = loadBuildConstraints BCSDefault - -data BuildConstraintsSource - = BCSDefault - | BCSFile FilePath - | BCSWeb Request - deriving (Show) - -loadBuildConstraints :: BuildConstraintsSource -> Manager -> IO BuildConstraints -loadBuildConstraints bcs man = do - case bcs of - BCSDefault -> do - e <- isFile fp0 - if e - then loadFile fp0 - else loadReq req0 - BCSFile fp -> loadFile fp - BCSWeb req -> loadReq req - where - fp0 = "build-constraints.yaml" - req0 = "https://raw.githubusercontent.com/fpco/stackage/master/build-constraints.yaml" - - loadFile fp = decodeFileEither (fpToString fp) >>= either throwIO toBC - loadReq req = httpLbs req man >>= - either throwIO toBC . decodeEither' . toStrict . responseBody - - -getSystemInfo :: IO SystemInfo -getSystemInfo = do - siCorePackages <- getCorePackages - siCoreExecutables <- getCoreExecutables - siGhcVersion <- getGhcVersion - return SystemInfo {..} - where - -- FIXME consider not hard-coding the next two values - siOS = Distribution.System.Linux - siArch = Distribution.System.X86_64 - -data ConstraintFile = ConstraintFile - { cfPackageFlags :: Map PackageName (Map FlagName Bool) - , cfSkippedTests :: Set PackageName - , cfExpectedTestFailures :: Set PackageName - , cfExpectedHaddockFailures :: Set PackageName - , cfSkippedBenchmarks :: Set PackageName - , cfPackages :: Map Maintainer (Vector Dependency) - , cfGithubUsers :: Map Text (Set Text) - , cfSkippedLibProfiling :: Set PackageName - } - -instance FromJSON ConstraintFile where - parseJSON = withObject "ConstraintFile" $ \o -> do - cfPackageFlags <- (goPackageMap . fmap goFlagMap) <$> o .: "package-flags" - cfSkippedTests <- getPackages o "skipped-tests" - cfExpectedTestFailures <- getPackages o "expected-test-failures" - cfExpectedHaddockFailures <- getPackages o "expected-haddock-failures" - cfSkippedBenchmarks <- getPackages o "skipped-benchmarks" - cfSkippedLibProfiling <- getPackages o "skipped-profiling" - cfPackages <- o .: "packages" - >>= mapM (mapM toDep) - . Map.mapKeysWith const Maintainer - cfGithubUsers <- o .: "github-users" - return ConstraintFile {..} - where - goFlagMap = Map.mapKeysWith const FlagName - goPackageMap = Map.mapKeysWith const PackageName - getPackages o name = (setFromList . map PackageName) <$> o .: name - - toDep :: Monad m => Text -> m Dependency - toDep = either (fail . show) return . simpleParse - -toBC :: ConstraintFile -> IO BuildConstraints -toBC ConstraintFile {..} = do - bcSystemInfo <- getSystemInfo - return BuildConstraints {..} - where - combine (maintainer, range1) (_, range2) = - (maintainer, intersectVersionRanges range1 range2) - revmap = unionsWith combine $ ($ []) $ execWriter - $ forM_ (mapToList cfPackages) - $ \(maintainer, deps) -> forM_ deps - $ \(Dependency name range) -> - tell (singletonMap name (maintainer, range):) - - bcPackages = Map.keysSet revmap - - bcPackageConstraints name = - PackageConstraints {..} - where - mpair = lookup name revmap - pcMaintainer = fmap fst mpair - pcVersionRange = maybe anyVersion snd mpair - pcEnableLibProfile = not (name `member` cfSkippedLibProfiling) - pcTests - | name `member` cfSkippedTests = Don'tBuild - | name `member` cfExpectedTestFailures = ExpectFailure - | otherwise = ExpectSuccess - pcBuildBenchmarks = name `notMember` cfSkippedBenchmarks - pcHaddocks - | name `member` cfExpectedHaddockFailures = ExpectFailure - - | otherwise = ExpectSuccess - pcFlagOverrides = fromMaybe mempty $ lookup name cfPackageFlags - - bcGithubUsers = cfGithubUsers diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs deleted file mode 100644 index b8bc5376..00000000 --- a/Stackage/BuildPlan.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} --- | Representation of a concrete build plan, and how to generate a new one --- based on constraints. -module Stackage.BuildPlan - ( BuildPlan (..) - , PackagePlan (..) - , newBuildPlan - , makeToolMap - , getLatestAllowedPlans - ) where - -import Control.Monad.State.Strict (execState, get, put) -import Data.Aeson -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Distribution.Compiler -import Distribution.PackageDescription -import Stackage.BuildConstraints -import Stackage.GithubPings -import Stackage.PackageDescription -import Stackage.PackageIndex -import Stackage.Prelude - -data BuildPlan = BuildPlan - { bpSystemInfo :: SystemInfo - , bpTools :: Vector (PackageName, Version) - , bpPackages :: Map PackageName PackagePlan - , bpGithubUsers :: Map Text (Set Text) - } - deriving (Show, Eq) - -instance ToJSON BuildPlan where - toJSON BuildPlan {..} = object - [ "system-info" .= bpSystemInfo - , "tools" .= map goTool bpTools - , "packages" .= Map.mapKeysWith const unPackageName bpPackages - , "github-users" .= bpGithubUsers - ] - where - goTool (k, v) = object - [ "name" .= display k - , "version" .= display v - ] -instance FromJSON BuildPlan where - parseJSON = withObject "BuildPlan" $ \o -> do - bpSystemInfo <- o .: "system-info" - bpTools <- (o .: "tools") >>= mapM goTool - bpPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages") - bpGithubUsers <- o .:? "github-users" .!= mempty - return BuildPlan {..} - where - goTool = withObject "Tool" $ \o -> (,) - <$> ((o .: "name") >>= - either (fail . show) return . simpleParse . asText) - <*> ((o .: "version") >>= - either (fail . show) return . simpleParse . asText) - -data PackagePlan = PackagePlan - { ppVersion :: Version - , ppGithubPings :: Set Text - , ppUsers :: Set PackageName - , ppConstraints :: PackageConstraints - , ppDesc :: SimpleDesc - } - deriving (Show, Eq) - -instance ToJSON PackagePlan where - toJSON PackagePlan {..} = object - [ "version" .= asText (display ppVersion) - , "github-pings" .= ppGithubPings - , "users" .= map unPackageName (unpack ppUsers) - , "constraints" .= ppConstraints - , "description" .= ppDesc - ] -instance FromJSON PackagePlan where - parseJSON = withObject "PackageBuild" $ \o -> do - ppVersion <- o .: "version" - >>= either (fail . show) return - . simpleParse . asText - ppGithubPings <- o .:? "github-pings" .!= mempty - ppUsers <- Set.map PackageName <$> (o .:? "users" .!= mempty) - ppConstraints <- o .: "constraints" - ppDesc <- o .: "description" - return PackagePlan {..} - --- | Make a build plan given these package set and build constraints. -newBuildPlan :: MonadIO m => Map PackageName PackagePlan -> BuildConstraints -> m BuildPlan -newBuildPlan packagesOrig bc@BuildConstraints {..} = liftIO $ do - let toolMap = makeToolMap packagesOrig - packages = populateUsers $ removeUnincluded bc toolMap packagesOrig - toolNames :: [ExeName] - toolNames = concatMap (Map.keys . sdTools . ppDesc) packages - tools <- topologicalSortTools toolMap $ mapFromList $ do - exeName <- toolNames - guard $ exeName `notMember` siCoreExecutables - packageName <- maybe mempty setToList $ lookup exeName toolMap - packagePlan <- maybeToList $ lookup packageName packagesOrig - return (packageName, packagePlan) - -- FIXME topologically sort packages? maybe just leave that to the build phase - return BuildPlan - { bpSystemInfo = bcSystemInfo - , bpTools = tools - , bpPackages = packages - , bpGithubUsers = bcGithubUsers - } - where - SystemInfo {..} = bcSystemInfo - -makeToolMap :: Map PackageName PackagePlan - -> Map ExeName (Set PackageName) -makeToolMap = - unionsWith (++) . map go . mapToList - where - go (packageName, pp) = - foldMap go' $ sdProvidedExes $ ppDesc pp - where - go' exeName = singletonMap exeName (singletonSet packageName) - -topologicalSortTools :: MonadThrow m - => Map ExeName (Set PackageName) - -> Map PackageName PackagePlan - -> m (Vector (PackageName, Version)) -topologicalSortTools toolMap = topologicalSort - ppVersion - (concatMap (fromMaybe mempty . flip lookup toolMap) . Map.keys . sdTools . ppDesc) - --- | Include only packages which are dependencies of the required packages and --- their build tools. -removeUnincluded :: BuildConstraints - -> Map ExeName (Set PackageName) - -> Map PackageName PackagePlan - -> Map PackageName PackagePlan -removeUnincluded BuildConstraints {..} toolMap orig = - mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig - where - SystemInfo {..} = bcSystemInfo - - included :: Set PackageName - included = flip execState mempty $ mapM_ add bcPackages - - add name = do - inc <- get - when (name `notMember` inc) $ do - put $ insertSet name inc - case lookup name orig of - Nothing -> return () - Just pb -> do - mapM_ add $ Map.keys $ sdPackages $ ppDesc pb - forM_ (Map.keys $ sdTools $ ppDesc pb) $ - \exeName -> when (exeName `notMember` siCoreExecutables) - $ mapM_ add $ fromMaybe mempty $ lookup exeName toolMap - -populateUsers :: Map PackageName PackagePlan - -> Map PackageName PackagePlan -populateUsers orig = - mapWithKey go orig - where - go name pb = pb { ppUsers = foldMap (go2 name) (mapToList orig) } - - go2 dep (user, pb) - | dep `member` sdPackages (ppDesc pb) = singletonSet user - | otherwise = mempty - --- | Check whether the given package/version combo meets the constraints --- currently in place. -isAllowed :: BuildConstraints - -> PackageName -> Version -> Bool -isAllowed bc = \name version -> - case lookup name $ siCorePackages $ bcSystemInfo bc of - Just _ -> False -- never reinstall a core package - Nothing -> withinRange version $ pcVersionRange $ bcPackageConstraints bc name - -mkPackagePlan :: MonadThrow m - => BuildConstraints - -> GenericPackageDescription - -> m PackagePlan -mkPackagePlan bc gpd = do - ppDesc <- toSimpleDesc CheckCond {..} gpd - return PackagePlan {..} - where - PackageIdentifier name ppVersion = package $ packageDescription gpd - ppGithubPings = getGithubPings bc gpd - ppConstraints = bcPackageConstraints bc name - ppUsers = mempty -- must be filled in later - - ccPackageName = name - ccOS = siOS - ccArch = siArch - ccCompilerFlavor = Distribution.Compiler.GHC - ccCompilerVersion = siGhcVersion - ccFlags = flags - ccIncludeTests = pcTests ppConstraints /= Don'tBuild - ccIncludeBenchmarks = pcBuildBenchmarks ppConstraints - - SystemInfo {..} = bcSystemInfo bc - - overrides = pcFlagOverrides ppConstraints - getFlag MkFlag {..} = - (flagName, fromMaybe flagDefault $ lookup flagName overrides) - flags = mapFromList $ map getFlag $ genPackageFlags gpd - -getLatestAllowedPlans :: MonadIO m => BuildConstraints -> m (Map PackageName PackagePlan) -getLatestAllowedPlans bc = - getLatestDescriptions - (isAllowed bc) - (mkPackagePlan bc) diff --git a/Stackage/CheckBuildPlan.hs b/Stackage/CheckBuildPlan.hs deleted file mode 100644 index 74bf3b83..00000000 --- a/Stackage/CheckBuildPlan.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} --- | Confirm that a build plan has a consistent set of dependencies. -module Stackage.CheckBuildPlan - ( checkBuildPlan - , BadBuildPlan - ) where - -import Control.Monad.Writer.Strict (Writer, execWriter, tell) -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import Stackage.BuildConstraints -import Stackage.BuildPlan -import Stackage.PackageDescription -import Stackage.Prelude - --- | Check the build plan for missing deps, wrong versions, etc. -checkBuildPlan :: (MonadThrow m) => BuildPlan -> m () -checkBuildPlan BuildPlan {..} - | null errs' = return () - | otherwise = throwM errs - where - allPackages = map (,mempty) (siCorePackages bpSystemInfo) ++ - map (ppVersion &&& M.keys . M.filter libAndExe . sdPackages . ppDesc) bpPackages - errs@(BadBuildPlan errs') = - execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages - -- Only looking at libraries and executables, benchmarks and tests - -- are allowed to create cycles (e.g. test-framework depends on - -- text, which uses test-framework in its test-suite). - libAndExe (DepInfo cs _) = any (flip elem [CompLibrary,CompExecutable]) cs - --- | For a given package name and plan, check that its dependencies are: --- --- 1. Existent (existing in the provided package map) --- 2. Within version range --- 3. Check for dependency cycles. -checkDeps :: Map PackageName (Version,[PackageName]) - -> (PackageName, PackagePlan) - -> Writer BadBuildPlan () -checkDeps allPackages (user, pb) = - mapM_ go $ mapToList $ sdPackages $ ppDesc pb - where - go (dep, diRange -> range) = - case lookup dep allPackages of - Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap - Just (version,deps) - | version `withinRange` range -> - occursCheck allPackages - (\d v -> - tell $ BadBuildPlan $ singletonMap - (d,v) - errMap) - dep - deps - [] - | otherwise -> tell $ BadBuildPlan $ singletonMap - (dep, Just version) - errMap - where - errMap = singletonMap pu range - pu = PkgUser - { puName = user - , puVersion = ppVersion pb - , puMaintainer = pcMaintainer $ ppConstraints pb - , puGithubPings = ppGithubPings pb - } - --- | Check whether the package(s) occurs within its own dependency --- tree. -occursCheck - :: Monad m - => Map PackageName (Version,[PackageName]) - -- ^ All packages. - -> (PackageName -> Maybe Version -> m ()) - -- ^ Report an erroneous package. - -> PackageName - -- ^ Starting package to check for cycles in. - -> [PackageName] - -- ^ Dependencies of the package. - -> [PackageName] - -- ^ Previously seen packages up the dependency tree. - -> m () -occursCheck allPackages reportError = - go - where - go pkg deps seen = - case find (flip elem seen) deps of - Just cyclic -> - reportError cyclic $ - fmap fst (lookup cyclic allPackages) - Nothing -> - forM_ deps $ - \pkg' -> - case lookup pkg' allPackages of - Just (_v,deps') - | pkg' /= pkg -> go pkg' deps' seen' - _ -> return () - where seen' = pkg : seen - -data PkgUser = PkgUser - { puName :: PackageName - , puVersion :: Version - , puMaintainer :: Maybe Maintainer - , puGithubPings :: Set Text - } - deriving (Eq, Ord) - -pkgUserShow1 :: PkgUser -> Text -pkgUserShow1 PkgUser {..} = concat - [ display puName - , "-" - , display puVersion - ] - -pkgUserShow2 :: PkgUser -> Text -pkgUserShow2 PkgUser {..} = unwords - $ (maybe "No maintainer" unMaintainer puMaintainer ++ ".") - : map (cons '@') (setToList puGithubPings) - -newtype BadBuildPlan = - BadBuildPlan (Map (PackageName, Maybe Version) (Map PkgUser VersionRange)) - deriving Typeable -instance Exception BadBuildPlan -instance Show BadBuildPlan where - show (BadBuildPlan errs) = - unpack $ concatMap go $ mapToList errs - where - go ((dep, mdepVer), users) = unlines - $ "" - : showDepVer dep mdepVer - : map showUser (mapToList users) - - showDepVer :: PackageName -> Maybe Version -> Text - showDepVer dep Nothing = display dep ++ " (not present) depended on by:" - showDepVer dep (Just version) = concat - [ display dep - , "-" - , display version - , " depended on by:" - ] - - showUser :: (PkgUser, VersionRange) -> Text - showUser (pu, range) = concat - [ "- " - , pkgUserShow1 pu - , " (" - -- add a space after < to avoid confusing Markdown processors (like - -- Github's issue tracker) - , T.replace "<" "< " $ display range - , "). " - , pkgUserShow2 pu - ] - -instance Monoid BadBuildPlan where - mempty = BadBuildPlan mempty - mappend (BadBuildPlan x) (BadBuildPlan y) = - BadBuildPlan $ unionWith (unionWith intersectVersionRanges) x y diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs deleted file mode 100644 index ee4996d6..00000000 --- a/Stackage/CompleteBuild.hs +++ /dev/null @@ -1,337 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Stackage.CompleteBuild - ( BuildType (..) - , BumpType (..) - , BuildFlags (..) - , completeBuild - , justCheck - , justUploadNightly - , getStackageAuthToken - ) where - -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (withAsync) -import Data.Default.Class (def) -import Data.Semigroup (Max (..), Option (..)) -import Data.Text.Read (decimal) -import Data.Time -import Data.Yaml (decodeFileEither, encodeFile) -import Network.HTTP.Client -import Network.HTTP.Client.TLS (tlsManagerSettings) -import Stackage.BuildConstraints -import Stackage.BuildPlan -import Stackage.CheckBuildPlan -import Stackage.PerformBuild -import Stackage.Prelude -import Stackage.ServerBundle -import Stackage.UpdateBuildPlan -import Stackage.Upload -import System.Environment (lookupEnv) -import System.IO (BufferMode (LineBuffering), hSetBuffering) - --- | Flags passed in from the command line. -data BuildFlags = BuildFlags - { bfEnableTests :: !Bool - , bfEnableHaddock :: !Bool - , bfDoUpload :: !Bool - , bfEnableLibProfile :: !Bool - , bfEnableExecDyn :: !Bool - , bfVerbose :: !Bool - , bfSkipCheck :: !Bool - , 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 diff --git a/Stackage/CorePackages.hs b/Stackage/CorePackages.hs deleted file mode 100644 index 896ff002..00000000 --- a/Stackage/CorePackages.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -module Stackage.CorePackages - ( getCorePackages - , getCoreExecutables - , getGhcVersion - ) where - -import qualified Data.Text as T -import Filesystem (listDirectory) -import Stackage.Prelude -import System.Directory (findExecutable) - --- | Get a @Map@ of all of the core packages. Core packages are defined as --- packages which ship with GHC itself. --- --- Precondition: GHC global package database has only core packages, and GHC --- ships with just a single version of each packages. -getCorePackages :: IO (Map PackageName Version) -getCorePackages = - withCheckedProcess cp $ \ClosedStream src Inherited -> - src $$ decodeUtf8C =$ linesUnboundedC =$ foldMapMC parsePackage - where - cp = proc "ghc-pkg" ["--no-user-package-conf", "list"] - parsePackage t - | ":" `isInfixOf` t = return mempty - | Just p <- stripSuffix "-" p' = singletonMap - <$> simpleParse p - <*> simpleParse v - | otherwise = return mempty - where - (p', v) = T.breakOnEnd "-" $ dropParens $ T.strip t - - dropParens s - | length s > 2 && headEx s == '(' && lastEx s == ')' = - initEx $ tailEx s - | otherwise = s - --- | A list of executables that are shipped with GHC. -getCoreExecutables :: IO (Set ExeName) -getCoreExecutables = do - mfp <- findExecutable "ghc" - dir <- - case mfp of - Nothing -> error "No ghc executable found on PATH" - Just fp -> return $ directory $ fpFromString fp - (setFromList . map (ExeName . fpToText . filename)) <$> listDirectory dir - -getGhcVersion :: IO Version -getGhcVersion = do - withCheckedProcess (proc "ghc" ["--numeric-version"]) $ - \ClosedStream src Inherited -> - (src $$ decodeUtf8C =$ foldC) >>= simpleParse diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs deleted file mode 100644 index 27b7f9e1..00000000 --- a/Stackage/GhcPkg.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} --- | General commands related to ghc-pkg. - -module Stackage.GhcPkg - ( setupPackageDatabase - ) where - -import Data.Conduit -import qualified Data.Conduit.List as CL -import Data.Conduit.Process -import qualified Data.Conduit.Text as CT -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T -import Distribution.Compat.ReadP -import Distribution.Package -import Distribution.Text (parse) -import Filesystem.Path.CurrentOS (FilePath) -import qualified Filesystem.Path.CurrentOS as FP -import Data.Map (Map) -import Data.Version (Version) -import Stackage.Prelude -import Filesystem (removeTree) - -setupPackageDatabase - :: Maybe FilePath -- ^ database location, Nothing if using global DB - -> FilePath -- ^ documentation root - -> (ByteString -> IO ()) -- ^ logging - -> Map PackageName Version -- ^ packages and versions to be installed - -> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package - -> IO (Set PackageName) -- ^ packages remaining in the database after cleanup -setupPackageDatabase mdb docDir log' toInstall onUnregister = do - registered1 <- getRegisteredPackages flags - forM_ registered1 $ \pi@(PackageIdentifier name version) -> - case lookup name toInstall of - Just version' | version /= version' -> unregisterPackage log' onUnregister docDir flags pi - _ -> return () - broken <- getBrokenPackages flags - forM_ broken $ unregisterPackage log' onUnregister docDir flags - foldMap (\(PackageIdentifier name _) -> singletonSet name) - <$> getRegisteredPackages flags - where - flags = ghcPkgFlags mdb - -ghcPkgFlags :: Maybe FilePath -> [String] -ghcPkgFlags mdb = - "--no-user-package-db" : - case mdb of - Nothing -> ["--global"] - Just fp -> ["--package-db=" ++ fpToString fp] - --- | Get broken packages. -getBrokenPackages :: [String] -> IO [PackageIdentifier] -getBrokenPackages flags = do - (_,ps) <- sourceProcessWithConsumer - (proc - "ghc-pkg" - ("check" : "--simple-output" : flags)) - (CT.decodeUtf8 $= CT.lines $= CL.consume) - return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) - --- | Get available packages. -getRegisteredPackages :: [String] -> IO [PackageIdentifier] -getRegisteredPackages flags = do - (_,ps) <- sourceProcessWithConsumer - (proc - "ghc-pkg" - ("list" : "--simple-output" : flags)) - (CT.decodeUtf8 $= CT.lines $= CL.consume) - return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) - --- | Parse a package identifier: foo-1.2.3 -parsePackageIdent :: Text -> Maybe PackageIdentifier -parsePackageIdent = fmap fst . - listToMaybe . - filter (null . snd) . - readP_to_S parse . T.unpack - --- | Unregister a package. -unregisterPackage :: (ByteString -> IO ()) -- ^ log func - -> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package - -> FilePath -- ^ doc directory - -> [String] -> PackageIdentifier -> IO () -unregisterPackage log' onUnregister docDir flags ident@(PackageIdentifier name _) = do - log' $ "Unregistering " ++ encodeUtf8 (display ident) ++ "\n" - onUnregister ident - - -- Delete libraries - sourceProcessWithConsumer - (proc "ghc-pkg" ("describe" : flags ++ [unpack $ display ident])) - (CT.decodeUtf8 - $= CT.lines - $= CL.mapMaybe parseLibraryDir - $= CL.mapM_ (void . tryIO . removeTree)) - - void (readProcessWithExitCode - "ghc-pkg" - ("unregister": flags ++ ["--force", unpack $ display name]) - "") - - void $ tryIO $ removeTree $ docDir fpFromText (display ident) - where - parseLibraryDir = fmap fpFromText . stripPrefix "library-dirs: " diff --git a/Stackage/GithubPings.hs b/Stackage/GithubPings.hs deleted file mode 100644 index bb7369f4..00000000 --- a/Stackage/GithubPings.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -module Stackage.GithubPings - ( getGithubPings - ) where - -import Distribution.PackageDescription -import Stackage.BuildConstraints -import Stackage.Prelude - --- | Determine accounts to be pinged on Github based on various metadata in the --- package description. -getGithubPings :: BuildConstraints -- ^ for mapping to pingees - -> GenericPackageDescription -> Set Text -getGithubPings bc gpd = - foldMap (\(pack -> name) -> fromMaybe (singletonSet name) (lookup name (bcGithubUsers bc))) $ - goHomepage (homepage $ packageDescription gpd) ++ - concatMap goRepo (sourceRepos $ packageDescription gpd) - where - goHomepage t = do - prefix <- - [ "http://github.com/" - , "https://github.com/" - , "git://github.com/" - , "git@github.com:" - ] - t' <- maybeToList $ stripPrefix prefix t - let t'' = takeWhile (/= '/') t' - guard $ not $ null t'' - return t'' - - goRepo sr = - case (repoType sr, repoLocation sr) of - (Just Git, Just s) -> goHomepage s - _ -> [] diff --git a/Stackage/InstallBuild.hs b/Stackage/InstallBuild.hs deleted file mode 100644 index 2f896e35..00000000 --- a/Stackage/InstallBuild.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Stackage.InstallBuild - ( InstallFlags (..) - , BuildPlanSource (..) - , installBuild - ) where - -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Compression.GZip as GZip -import qualified Data.Yaml as Yaml -import Network.HTTP.Client -import Network.HTTP.Client.TLS (tlsManagerSettings) -import Stackage.BuildPlan -import Stackage.CheckBuildPlan -import Stackage.PerformBuild -import Stackage.Prelude -import System.IO (BufferMode (LineBuffering), hSetBuffering) - --- | Flags passed in from the command line. -data InstallFlags = InstallFlags - { ifPlanSource :: !BuildPlanSource - , ifInstallDest :: !FilePath - , ifLogDir :: !(Maybe FilePath) - , ifJobs :: !Int - , ifGlobalInstall :: !Bool - , ifEnableTests :: !Bool - , ifEnableHaddock :: !Bool - , ifEnableLibProfiling :: !Bool - , ifEnableExecDyn :: !Bool - , ifVerbose :: !Bool - , ifSkipCheck :: !Bool - , 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" diff --git a/Stackage/PackageDescription.hs b/Stackage/PackageDescription.hs deleted file mode 100644 index 24263701..00000000 --- a/Stackage/PackageDescription.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} --- | Manipulate @GenericPackageDescription@ from Cabal into something more --- useful for us. -module Stackage.PackageDescription - ( SimpleDesc (..) - , toSimpleDesc - , CheckCond (..) - , Component (..) - , DepInfo (..) - ) where - -import Control.Monad.Writer.Strict (MonadWriter, execWriterT, - tell) -import Data.Aeson -import qualified Data.Map as Map -import Distribution.Compiler (CompilerFlavor) -import Distribution.Package (Dependency (..)) -import Distribution.PackageDescription -import Distribution.System (Arch, OS) -import Stackage.Prelude - -data Component = CompLibrary - | CompExecutable - | CompTestSuite - | CompBenchmark - deriving (Show, Read, Eq, Ord, Enum, Bounded) - -compToText :: Component -> Text -compToText CompLibrary = "library" -compToText CompExecutable = "executable" -compToText CompTestSuite = "test-suite" -compToText CompBenchmark = "benchmark" - -instance ToJSON Component where - toJSON = toJSON . compToText -instance FromJSON Component where - parseJSON = withText "Component" $ \t -> maybe - (fail $ "Invalid component: " ++ unpack t) - return - (lookup t comps) - where - comps = asHashMap $ mapFromList $ map (compToText &&& id) [minBound..maxBound] - -data DepInfo = DepInfo - { diComponents :: Set Component - , diRange :: VersionRange - } - deriving (Show, Eq) - -instance Semigroup DepInfo where - DepInfo a x <> DepInfo b y = DepInfo - (a <> b) - (intersectVersionRanges x y) -instance ToJSON DepInfo where - toJSON DepInfo {..} = object - [ "components" .= diComponents - , "range" .= display diRange - ] -instance FromJSON DepInfo where - parseJSON = withObject "DepInfo" $ \o -> do - diComponents <- o .: "components" - diRange <- o .: "range" >>= either (fail . show) return . simpleParse - return DepInfo {..} - --- | A simplified package description that tracks: --- --- * Package dependencies --- --- * Build tool dependencies --- --- * Provided executables --- --- It has fully resolved all conditionals -data SimpleDesc = SimpleDesc - { sdPackages :: Map PackageName DepInfo - , sdTools :: Map ExeName DepInfo - , sdProvidedExes :: Set ExeName - , sdModules :: Set Text - -- ^ modules exported by the library - } - deriving (Show, Eq) -instance Monoid SimpleDesc where - mempty = SimpleDesc mempty mempty mempty mempty - mappend (SimpleDesc a b c d) (SimpleDesc w x y z) = SimpleDesc - (unionWith (<>) a w) - (unionWith (<>) b x) - (c ++ y) - (d ++ z) -instance ToJSON SimpleDesc where - toJSON SimpleDesc {..} = object - [ "packages" .= Map.mapKeysWith const unPackageName sdPackages - , "tools" .= Map.mapKeysWith const unExeName sdTools - , "provided-exes" .= sdProvidedExes - , "modules" .= sdModules - ] -instance FromJSON SimpleDesc where - parseJSON = withObject "SimpleDesc" $ \o -> do - sdPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages") - sdTools <- Map.mapKeysWith const ExeName <$> (o .: "tools") - sdProvidedExes <- o .: "provided-exes" - sdModules <- o .: "modules" - return SimpleDesc {..} - --- | Convert a 'GenericPackageDescription' into a 'SimpleDesc' by following the --- constraints in the provided 'CheckCond'. -toSimpleDesc :: MonadThrow m - => CheckCond - -> GenericPackageDescription - -> m SimpleDesc -toSimpleDesc cc gpd = execWriterT $ do - forM_ (condLibrary gpd) $ tellTree cc CompLibrary libBuildInfo getModules - forM_ (condExecutables gpd) $ tellTree cc CompExecutable buildInfo noModules . snd - tell mempty { sdProvidedExes = setFromList - $ map (fromString . fst) - $ condExecutables gpd - } - when (ccIncludeTests cc) $ forM_ (condTestSuites gpd) - $ tellTree cc CompTestSuite testBuildInfo noModules . snd - when (ccIncludeBenchmarks cc) $ forM_ (condBenchmarks gpd) - $ tellTree cc CompBenchmark benchmarkBuildInfo noModules . snd - where - noModules = const mempty - getModules = setFromList . map display . exposedModules - --- | Convert a single CondTree to a 'SimpleDesc'. -tellTree :: (MonadWriter SimpleDesc m, MonadThrow m) - => CheckCond - -> Component - -> (a -> BuildInfo) - -> (a -> Set Text) -- ^ get module names - -> CondTree ConfVar [Dependency] a - -> m () -tellTree cc component getBI getModules = - loop - where - loop (CondNode dat deps comps) = do - tell mempty - { sdPackages = unionsWith (<>) $ flip map deps - $ \(Dependency x y) -> singletonMap x DepInfo - { diComponents = singletonSet component - , diRange = simplifyVersionRange y - } - , sdTools = unionsWith (<>) $ flip map (buildTools $ getBI dat) - $ \(Dependency name range) -> singletonMap - -- In practice, cabal files refer to the exe name, not the - -- package name. - (ExeName $ unPackageName name) - DepInfo - { diComponents = singletonSet component - , diRange = simplifyVersionRange range - } - , sdModules = getModules dat - } - forM_ comps $ \(cond, ontrue, onfalse) -> do - b <- checkCond cc cond - if b - then loop ontrue - else maybe (return ()) loop onfalse - --- | Resolve a condition to a boolean based on the provided 'CheckCond'. -checkCond :: MonadThrow m => CheckCond -> Condition ConfVar -> m Bool -checkCond CheckCond {..} cond0 = - go cond0 - where - go (Var (OS os)) = return $ os == ccOS - go (Var (Arch arch)) = return $ arch == ccArch - go (Var (Flag flag)) = - case lookup flag ccFlags of - Nothing -> throwM $ FlagNotDefined ccPackageName flag cond0 - Just b -> return b - go (Var (Impl flavor range)) = return - $ flavor == ccCompilerFlavor - && ccCompilerVersion `withinRange` range - go (Lit b) = return b - go (CNot c) = not `liftM` go c - go (CAnd x y) = (&&) `liftM` go x `ap` go y - go (COr x y) = (||) `liftM` go x `ap` go y - -data CheckCondException = FlagNotDefined PackageName FlagName (Condition ConfVar) - deriving (Show, Typeable) -instance Exception CheckCondException - -data CheckCond = CheckCond - { ccPackageName :: PackageName -- for debugging only - , ccOS :: OS - , ccArch :: Arch - , ccFlags :: Map FlagName Bool - , ccCompilerFlavor :: CompilerFlavor - , ccCompilerVersion :: Version - , ccIncludeTests :: Bool - , ccIncludeBenchmarks :: Bool - } diff --git a/Stackage/PackageIndex.hs b/Stackage/PackageIndex.hs deleted file mode 100644 index 6b4c8087..00000000 --- a/Stackage/PackageIndex.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ViewPatterns #-} --- | Dealing with the 00-index file and all its cabal files. -module Stackage.PackageIndex - ( sourcePackageIndex - , UnparsedCabalFile (..) - , getLatestDescriptions - ) where - -import qualified Codec.Archive.Tar as Tar -import Data.Conduit.Lazy (MonadActive, - lazyConsume) -import qualified Data.Text as T -import Distribution.PackageDescription (package, - packageDescription) -import Distribution.PackageDescription.Parse (ParseResult (..), - parsePackageDescription) -import Distribution.ParseUtils (PError) -import Stackage.Prelude -import System.Directory (getAppUserDataDirectory) - --- | Name of the 00-index.tar downloaded from Hackage. -getPackageIndexPath :: MonadIO m => m FilePath -getPackageIndexPath = liftIO $ do - c <- getCabalRoot - configLines <- runResourceT $ sourceFile (c "config") - $$ decodeUtf8C - =$ linesUnboundedC - =$ concatMapC getRemoteCache - =$ sinkList - case configLines of - [x] -> return $ x "hackage.haskell.org" "00-index.tar" - [] -> error $ "No remote-repo-cache found in Cabal config file" - _ -> error $ "Multiple remote-repo-cache entries found in Cabal config file" - where - getCabalRoot :: IO FilePath - getCabalRoot = fpFromString <$> getAppUserDataDirectory "cabal" - - getRemoteCache s = do - ("remote-repo-cache", stripPrefix ":" -> Just v) <- Just $ break (== ':') s - Just $ fpFromText $ T.strip v - --- | A cabal file with name and version parsed from the filepath, and the --- package description itself ready to be parsed. It's left in unparsed form --- for efficiency. -data UnparsedCabalFile = UnparsedCabalFile - { ucfName :: PackageName - , ucfVersion :: Version - , ucfParse :: forall m. MonadThrow m => m GenericPackageDescription - } - --- | Stream all of the cabal files from the 00-index tar file. -sourcePackageIndex :: (MonadThrow m, MonadResource m, MonadActive m, MonadBaseControl IO m) - => Producer m UnparsedCabalFile -sourcePackageIndex = do - fp <- getPackageIndexPath - -- yay for the tar package. Use lazyConsume instead of readFile to get some - -- kind of resource protection - lbs <- lift $ fromChunks <$> lazyConsume (sourceFile fp) - loop (Tar.read lbs) - where - loop (Tar.Next e es) = goE e >> loop es - loop Tar.Done = return () - loop (Tar.Fail e) = throwM e - - goE e - | Just front <- stripSuffix ".cabal" $ pack $ Tar.entryPath e - , Tar.NormalFile lbs _size <- Tar.entryContent e = do - (name, version) <- parseNameVersion front - yield UnparsedCabalFile - { ucfName = name - , ucfVersion = version - , ucfParse = goContent (Tar.entryPath e) name version lbs - } - | otherwise = return () - - goContent fp name version lbs = - case parsePackageDescription $ unpack $ decodeUtf8 lbs of - ParseFailed e -> throwM $ CabalParseException (fpFromString fp) e - ParseOk _warnings gpd -> do - let pd = packageDescription gpd - PackageIdentifier name' version' = package pd - when (name /= name' || version /= version') $ - throwM $ MismatchedNameVersion (fpFromString fp) - name name' version version' - return gpd - - parseNameVersion t1 = do - let (p', t2) = break (== '/') $ T.replace "\\" "/" t1 - p <- simpleParse p' - t3 <- maybe (throwM $ InvalidCabalPath t1 "no slash") return - $ stripPrefix "/" t2 - let (v', t4) = break (== '/') t3 - v <- simpleParse v' - when (t4 /= cons '/' p') $ throwM $ InvalidCabalPath t1 $ "Expected at end: " ++ p' - return (p, v) - -data InvalidCabalPath = InvalidCabalPath Text Text - deriving (Show, Typeable) -instance Exception InvalidCabalPath - -data CabalParseException = CabalParseException FilePath PError - | MismatchedNameVersion FilePath PackageName PackageName Version Version - deriving (Show, Typeable) -instance Exception CabalParseException - --- | Get all of the latest descriptions for name/version pairs matching the --- given criterion. -getLatestDescriptions :: MonadIO m - => (PackageName -> Version -> Bool) - -> (GenericPackageDescription -> IO desc) - -> m (Map PackageName desc) -getLatestDescriptions f parseDesc = liftIO $ do - m <- runResourceT $ sourcePackageIndex $$ filterC f' =$ foldlC add mempty - forM m $ \ucf -> liftIO $ ucfParse ucf >>= parseDesc - where - f' ucf = f (ucfName ucf) (ucfVersion ucf) - add m ucf = - case lookup name m of - Just ucf' | ucfVersion ucf < ucfVersion ucf' -> m - _ -> insertMap name ucf m - where - name = ucfName ucf diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs deleted file mode 100644 index 06c1edc6..00000000 --- a/Stackage/PerformBuild.hs +++ /dev/null @@ -1,560 +0,0 @@ --- | Perform an actual build, generate a binary package database and a --- documentation directory in the process. -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Stackage.PerformBuild - ( performBuild - , PerformBuild (..) - , BuildException (..) - , pbDocDir - ) where - -import Control.Concurrent.Async (async) -import Control.Concurrent.STM.TSem -import Control.Monad.Writer.Strict (execWriter, tell) -import qualified Data.Map as Map -import Data.NonNull (fromNullable) -import Filesystem (canonicalizePath, createTree, - getWorkingDirectory, isDirectory, - removeTree, rename, isFile, removeFile) -import Filesystem.Path (parent) -import qualified Filesystem.Path as F -import Stackage.BuildConstraints -import Stackage.BuildPlan -import Stackage.GhcPkg -import Stackage.PackageDescription -import Stackage.Prelude hiding (pi) -import System.Directory (findExecutable) -import System.Environment (getEnvironment) -import System.IO (IOMode (WriteMode), - openBinaryFile) -import System.IO.Temp (withSystemTempDirectory) - -data BuildException = BuildException (Map PackageName BuildFailure) [Text] - deriving Typeable -instance Exception BuildException -instance Show BuildException where - show (BuildException m warnings) = - unlines $ map go (mapToList m) ++ map unpack warnings - where - go (PackageName name, bf) = concat - [ name - , ": " - , show bf - ] - -data BuildFailure = DependencyFailed PackageName - | DependencyMissing PackageName - | ToolMissing ExeName - | NotImplemented - | BuildFailureException SomeException - deriving (Show, Typeable) -instance Exception BuildFailure - -data PerformBuild = PerformBuild - { pbPlan :: BuildPlan - , pbInstallDest :: FilePath - , pbLog :: ByteString -> IO () - , pbLogDir :: FilePath - , pbJobs :: Int - , pbGlobalInstall :: Bool - -- ^ Register packages in the global database - , pbEnableTests :: Bool - , pbEnableHaddock :: Bool - , pbEnableLibProfiling :: Bool - , pbEnableExecDyn :: Bool - , pbVerbose :: Bool - , pbAllowNewer :: Bool - -- ^ Pass --allow-newer to cabal configure - , 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 diff --git a/Stackage/Prelude.hs b/Stackage/Prelude.hs deleted file mode 100644 index 28fff061..00000000 --- a/Stackage/Prelude.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -module Stackage.Prelude - ( module X - , module Stackage.Prelude - ) where - -import ClassyPrelude.Conduit as X -import Data.Aeson (FromJSON, ToJSON) -import Data.Conduit.Process as X -import qualified Data.Map as Map -import Data.Typeable (TypeRep, typeOf) -import Distribution.Package as X (PackageIdentifier (..), PackageName (PackageName)) -import Distribution.PackageDescription as X (FlagName (..), GenericPackageDescription) -import qualified Distribution.Text as DT -import Distribution.Version as X (Version (..), - VersionRange) -import Distribution.Version as X (withinRange) -import qualified Distribution.Version as C -import Filesystem (createTree) -import Filesystem.Path (parent) -import qualified Filesystem.Path as F - -unPackageName :: PackageName -> Text -unPackageName (PackageName str) = pack str - -unFlagName :: FlagName -> Text -unFlagName (FlagName str) = pack str - -mkPackageName :: Text -> PackageName -mkPackageName = PackageName . unpack - -mkFlagName :: Text -> FlagName -mkFlagName = FlagName . unpack - -display :: DT.Text a => a -> Text -display = fromString . DT.display - -simpleParse :: (MonadThrow m, DT.Text a, Typeable a) => Text -> m a -simpleParse orig = withTypeRep $ \rep -> - case DT.simpleParse str of - Nothing -> throwM (ParseFailedException rep (pack str)) - Just v -> return v - where - str = unpack orig - - withTypeRep :: Typeable a => (TypeRep -> m a) -> m a - withTypeRep f = - res - where - res = f (typeOf (unwrap res)) - - unwrap :: m a -> a - unwrap _ = error "unwrap" - -data ParseFailedException = ParseFailedException TypeRep Text - deriving (Show, Typeable) -instance Exception ParseFailedException - -newtype Maintainer = Maintainer { unMaintainer :: Text } - deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString) - --- | Name of an executable. -newtype ExeName = ExeName { unExeName :: Text } - deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString) - -intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange -intersectVersionRanges x y = C.simplifyVersionRange $ C.intersectVersionRanges x y - --- | There seems to be a bug in Cabal where serializing and deserializing --- version ranges winds up with different representations. So we have a --- super-simplifier to deal with that. -simplifyVersionRange :: VersionRange -> VersionRange -simplifyVersionRange vr = - fromMaybe (assert False vr') $ simpleParse $ display vr' - where - vr' = C.simplifyVersionRange vr - --- | Topologically sort so that items with dependencies occur after those --- dependencies. -topologicalSort :: (Ord key, Show key, MonadThrow m, Typeable key) - => (value -> finalValue) - -> (value -> Set key) -- ^ deps - -> Map key value - -> m (Vector (key, finalValue)) -topologicalSort toFinal toDeps = - loop id . mapWithKey removeSelfDeps . fmap (toDeps &&& toFinal) - where - removeSelfDeps k (deps, final) = (deleteSet k deps, final) - loop front toProcess | null toProcess = return $ pack $ front [] - loop front toProcess - | null noDeps = throwM $ NoEmptyDeps (map fst toProcess') - | otherwise = loop (front . noDeps') (mapFromList hasDeps) - where - toProcess' = fmap (first removeUnavailable) toProcess - allKeys = Map.keysSet toProcess - removeUnavailable = asSet . setFromList . filter (`member` allKeys) . setToList - (noDeps, hasDeps) = partition (null . fst . snd) $ mapToList toProcess' - noDeps' = (map (second snd) noDeps ++) - -data TopologicalSortException key = NoEmptyDeps (Map key (Set key)) - deriving (Show, Typeable) -instance (Show key, Typeable key) => Exception (TopologicalSortException key) - -copyDir :: FilePath -> FilePath -> IO () -copyDir src dest = - runResourceT $ sourceDirectoryDeep False src $$ mapM_C go - where - src' = src "" - go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do - let dest' = dest suffix - liftIO $ createTree $ parent dest' - sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ()) diff --git a/Stackage/ServerBundle.hs b/Stackage/ServerBundle.hs deleted file mode 100644 index 5aedb090..00000000 --- a/Stackage/ServerBundle.hs +++ /dev/null @@ -1,271 +0,0 @@ --- | Create a bundle to be uploaded to Stackage Server. -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Stackage.ServerBundle - ( serverBundle - , epochTime - , bpAllPackages - , docsListing - , createBundleV2 - , CreateBundleV2 (..) - , SnapshotType (..) - , writeIndexStyle - , DocMap - , PackageDocs (..) - ) where - -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Tar.Entry as Tar -import qualified Codec.Compression.GZip as GZip -import qualified Data.Map as M -import Data.Aeson (ToJSON (..), (.=), object, FromJSON (..), (.:), withObject) -import System.IO.Temp (withTempDirectory) -import qualified Data.Yaml as Y -import Filesystem (isFile, getWorkingDirectory, listDirectory, isDirectory, canonicalizePath) -import Foreign.C.Types (CTime (CTime)) -import Stackage.BuildConstraints -import Stackage.BuildPlan -import Stackage.Prelude -import System.IO.Temp (withTempDirectory) -import qualified System.PosixCompat.Time as PC -import qualified Text.XML as X -import Text.XML.Cursor -import System.PosixCompat.Files (createSymbolicLink) - --- | Get current time -epochTime :: IO Tar.EpochTime -epochTime = (\(CTime t) -> fromIntegral t) <$> PC.epochTime - --- | All package/versions in a build plan, including core packages. --- --- Note that this may include packages not available on Hackage. -bpAllPackages :: BuildPlan -> Map PackageName Version -bpAllPackages BuildPlan {..} = - siCorePackages bpSystemInfo ++ map ppVersion bpPackages - -serverBundle :: Tar.EpochTime - -> Text -- ^ title - -> Text -- ^ slug - -> BuildPlan - -> LByteString -serverBundle time title slug bp@BuildPlan {..} = GZip.compress $ Tar.write - [ fe "build-plan.yaml" (fromStrict $ Y.encode bp) - , fe "hackage" hackage - , fe "slug" (fromStrict $ encodeUtf8 slug) - , fe "desc" (fromStrict $ encodeUtf8 title) - , fe "core" corePackagesList - ] - where - fe name contents = - case Tar.toTarPath False name of - Left s -> error s - Right name' -> (Tar.fileEntry name' contents) - { Tar.entryTime = time - } - hackage = builderToLazy $ foldMap goPair $ mapToList packageMap - - -- need to remove some packages that don't exist on Hackage - packageMap = foldr deleteMap (bpAllPackages bp) $ map PackageName - [ "bin-package-db" - , "ghc" - , "rts" - ] - - goPair (name, version) = - toBuilder (display name) ++ - toBuilder (asText "-") ++ - toBuilder (display version) ++ - toBuilder (asText "\n") - - corePackagesList = - builderToLazy $ toBuilder $ unlines $ - map (\(PackageName name) -> name) - (M.keys $ siCorePackages bpSystemInfo) - --- | Package name is key -type DocMap = Map Text PackageDocs -data PackageDocs = PackageDocs - { pdVersion :: Text - , pdModules :: Map Text [Text] - -- ^ module name, path - } -instance ToJSON PackageDocs where - toJSON PackageDocs {..} = object - [ "version" .= pdVersion - , "modules" .= pdModules - ] -instance FromJSON PackageDocs where - parseJSON = withObject "PackageDocs" $ \o -> PackageDocs - <$> o .: "version" - <*> o .: "modules" - -docsListing :: BuildPlan - -> FilePath -- ^ docs directory - -> IO DocMap -docsListing bp docsDir = - fmap fold $ mapM go $ mapToList $ bpAllPackages bp - where - go :: (PackageName, Version) -> IO DocMap - go (package, version) = do -- handleAny (const $ return mempty) $ do - let dirname = fpFromText (concat - [ display package - , "-" - , display version - ]) - indexFP = (docsDir dirname "index.html") - ie <- isFile indexFP - if ie - then do - doc <- flip X.readFile indexFP X.def - { X.psDecodeEntities = X.decodeHtmlEntities - } - let cursor = fromDocument doc - getPair x = take 1 $ do - href <- attribute "href" x - let name = concat $ x $// content - guard $ not $ null name - return (href, name) - pairs = cursor $// attributeIs "class" "module" - &/ laxElement "a" >=> getPair - m <- fmap fold $ forM pairs $ \(href, name) -> do - let suffix = dirname fpFromText href - e <- isFile $ docsDir suffix - return $ if e - then asMap $ singletonMap name [fpToText dirname, href] - else mempty - return $ singletonMap (display package) $ PackageDocs - { pdVersion = display version - , pdModules = m - } - else return mempty - -data SnapshotType = STNightly - | STLTS !Int !Int -- ^ major, minor - deriving (Show, Read, Eq, Ord) - -instance ToJSON SnapshotType where - toJSON STNightly = object - [ "type" .= asText "nightly" - ] - toJSON (STLTS major minor) = object - [ "type" .= asText "lts" - , "major" .= major - , "minor" .= minor - ] -instance FromJSON SnapshotType where - parseJSON = withObject "SnapshotType" $ \o -> do - t <- o .: "type" - case asText t of - "nightly" -> return STNightly - "lts" -> STLTS - <$> o .: "major" - <*> o .: "minor" - _ -> fail $ "Unknown type for SnapshotType: " ++ unpack t - -data CreateBundleV2 = CreateBundleV2 - { cb2Plan :: BuildPlan - , cb2Type :: SnapshotType - , cb2DocsDir :: FilePath - , cb2Dest :: FilePath - } - --- | Create a V2 bundle, which contains the build plan, metadata, docs, and doc --- map. -createBundleV2 :: CreateBundleV2 -> IO () -createBundleV2 CreateBundleV2 {..} = do - docsDir <- canonicalizePath cb2DocsDir - docMap <- docsListing cb2Plan cb2DocsDir - - Y.encodeFile (fpToString $ docsDir "build-plan.yaml") cb2Plan - Y.encodeFile (fpToString $ docsDir "build-type.yaml") cb2Type - Y.encodeFile (fpToString $ docsDir "docs-map.yaml") docMap - void $ writeIndexStyle Nothing cb2DocsDir - - currentDir <- getWorkingDirectory - files <- listDirectory docsDir - - let args = "cfJ" - : fpToString (currentDir cb2Dest) - : "--dereference" - : map (fpToString . filename) files - cp = (proc "tar" args) { cwd = Just $ fpToString docsDir } - withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return () - -writeIndexStyle :: Maybe Text -- ^ snapshot id - -> FilePath -- ^ docs dir - -> IO [String] -writeIndexStyle msnapid dir = do - dirs <- fmap sort - $ runResourceT - $ sourceDirectory dir - $$ filterMC (liftIO . isDirectory) - =$ mapC (fpToString . filename) - =$ sinkList - writeFile (dir "index.html") $ mkIndex - (unpack <$> msnapid) - dirs - writeFile (dir "style.css") styleCss - return dirs - -mkIndex :: Maybe String -> [String] -> String -mkIndex msnapid dirs = concat - [ "\nHaddocks index" - , "" - , "" - , "" - , "" - , "
" - , "
" - , "

Haddock documentation index

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

Return to snapshot

" - ] - , "
    " - , concatMap toLI dirs - , "
" - ] - where - toLI name = concat - [ "
  • " - , name - , "
    • " - ] - -styleCss :: String -styleCss = concat - [ "@media (min-width: 530px) {" - , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }" - , "}" - , "@media (min-width: 760px) {" - , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }" - , "}" - , "ul {" - , " margin-left: 0;" - , " padding-left: 0;" - , " list-style-type: none;" - , "}" - , "body {" - , " background: #f0f0f0;" - , " font-family: 'Lato', sans-serif;" - , " text-shadow: 1px 1px 1px #ffffff;" - , " font-size: 20px;" - , " line-height: 30px;" - , " padding-bottom: 5em;" - , "}" - , "h1 {" - , " font-weight: normal;" - , " color: #06537d;" - , " font-size: 45px;" - , "}" - , ".return a {" - , " color: #06537d;" - , " font-style: italic;" - , "}" - , ".return {" - , " margin-bottom: 1em;" - , "}"] diff --git a/Stackage/UpdateBuildPlan.hs b/Stackage/UpdateBuildPlan.hs deleted file mode 100644 index 8c67c5ef..00000000 --- a/Stackage/UpdateBuildPlan.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} --- | Take an existing build plan and bump all packages to the newest version in --- the same major version number. -module Stackage.UpdateBuildPlan - ( updateBuildConstraints - , updateBuildPlan - ) where - -import qualified Data.Map as Map -import Distribution.Version (anyVersion, earlierVersion, - orLaterVersion) -import Stackage.BuildConstraints -import Stackage.BuildPlan -import Stackage.Prelude - -updateBuildPlan :: Map PackageName PackagePlan -> BuildPlan -> IO BuildPlan -updateBuildPlan packagesOrig - = newBuildPlan packagesOrig . updateBuildConstraints - -updateBuildConstraints :: BuildPlan -> BuildConstraints -updateBuildConstraints BuildPlan {..} = - BuildConstraints {..} - where - bcSystemInfo = bpSystemInfo - bcPackages = Map.keysSet bpPackages - bcGithubUsers = bpGithubUsers - - bcPackageConstraints name = PackageConstraints - { pcVersionRange = addBumpRange (maybe anyVersion pcVersionRange moldPC) - , pcMaintainer = moldPC >>= pcMaintainer - , pcTests = maybe ExpectSuccess pcTests moldPC - , pcHaddocks = maybe ExpectSuccess pcHaddocks moldPC - , pcBuildBenchmarks = maybe True pcBuildBenchmarks moldPC - , pcFlagOverrides = maybe mempty pcFlagOverrides moldPC - , pcEnableLibProfile = maybe False pcEnableLibProfile moldPC - } - where - moldBP = lookup name bpPackages - moldPC = ppConstraints <$> moldBP - - addBumpRange oldRange = - case moldBP of - Nothing -> oldRange - Just bp -> intersectVersionRanges oldRange - $ bumpRange $ ppVersion bp - - bumpRange version = intersectVersionRanges - (orLaterVersion version) - (earlierVersion $ bumpVersion version) - bumpVersion (Version (x:y:_) _) = Version [x, y + 1] [] - bumpVersion (Version [x] _) = Version [x, 1] [] - bumpVersion (Version [] _) = assert False $ Version [1, 0] [] diff --git a/Stackage/Upload.hs b/Stackage/Upload.hs deleted file mode 100644 index 64d21094..00000000 --- a/Stackage/Upload.hs +++ /dev/null @@ -1,272 +0,0 @@ --- | Upload to Stackage and Hackage -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -module Stackage.Upload - ( UploadBundle (..) - , SnapshotIdent (..) - , uploadBundle - , UploadDocs (..) - , uploadDocs - , uploadHackageDistro - , uploadHackageDistroNamed - , UploadDocMap (..) - , uploadDocMap - , uploadBundleV2 - , UploadBundleV2 (..) - , def - , 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 diff --git a/app/stackage.hs b/app/stackage.hs deleted file mode 100644 index d2618da2..00000000 --- a/app/stackage.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE TupleSections #-} - -module Main where - -import Control.Monad -import Data.Monoid -import Data.String (fromString) -import Data.Version -import Options.Applicative -import Filesystem.Path.CurrentOS (decodeString) -import Paths_stackage (version) -import Stackage.CompleteBuild -import Stackage.Upload -import Stackage.InstallBuild -import Network.HTTP.Client (withManager) -import Network.HTTP.Client.TLS (tlsManagerSettings) -import qualified Data.Text as T - -main :: IO () -main = - join $ - execParser $ - info - (helpOption <*> versionOption <*> config) - (header "Stackage" <> - fullDesc) - where - helpOption = - abortOption ShowHelpText $ - long "help" <> - help "Show this help text" - versionOption = - infoOption - ("stackage version " ++ showVersion version) - (long "version" <> - help "Show stackage version") - config = - subparser $ - mconcat - [ cmnd - (uncurry completeBuild) - (fmap (Nightly, ) buildFlags) - "nightly" - "Build, test and upload the Nightly snapshot" - , cmnd - (uncurry completeBuild) - (fmap (LTS Major, ) buildFlags) - "lts-major" - "Build, test and upload the LTS (major) snapshot" - , cmnd - (uncurry completeBuild) - (fmap (LTS Minor, ) buildFlags) - "lts-minor" - "Build, test and upload the LTS (minor) snapshot" - , cmnd - justUploadNightly - nightlyUploadFlags - "upload-nightly" - "Upload an already-built nightly snapshot" - , cmnd - (const justCheck) - (pure ()) - "check" - "Just check that the build plan is ok" - , cmnd - installBuild - installFlags - "install" - "Install a snapshot from an existing build plan" - , cmnd - uploadv2 - uploadv2Flags - "upload2" - "Upload a pre-existing v2 bundle" - ] - - cmnd exec parse name desc = - command name $ - info - (fmap exec (parse <**> helpOption)) - (progDesc desc) - - buildFlags = - BuildFlags <$> - fmap - not - (switch - (long "skip-tests" <> - help "Skip build and running the test suites")) <*> - fmap - not - (switch - (long "skip-haddock" <> - help "Skip generating haddock documentation")) <*> - fmap - not - (switch - (long "skip-upload" <> - help "Skip uploading bundle, docs, etc.")) <*> - switch - (long "enable-library-profiling" <> - help "Enable profiling when building") <*> - switch - (long "enable-executable-dynamic" <> - help "Enable dynamic executables when building") <*> - switch - (long "verbose" <> short 'v' <> - help "Output verbose detail about the build steps") <*> - switch - (long "skip-check" <> - help "Skip the check phase, and pass --allow-newer to cabal configure") <*> - switch - (long "upload-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") diff --git a/build-constraints.yaml b/build-constraints.yaml index 7596251a..206af9e8 100644 --- a/build-constraints.yaml +++ b/build-constraints.yaml @@ -93,6 +93,7 @@ packages: - shelly - smtLib - stackage + - stackage-curator - statistics-linreg - th-expand-syns - thyme diff --git a/cabal.config b/cabal.config deleted file mode 100644 index cc656768..00000000 --- a/cabal.config +++ /dev/null @@ -1,847 +0,0 @@ --- Stackage snapshot from: http://www.stackage.org/snapshot/nightly-2014-12-24 --- Please place this file next to your .cabal file as cabal.config --- To only use tested packages, uncomment the following line: --- remote-repo: stackage-nightly-2014-12-24:http://www.stackage.org/snapshot/nightly-2014-12-24 -constraints: abstract-deque ==0.3, - abstract-par ==0.3.3, - accelerate ==0.15.0.0, - ace ==0.6, - action-permutations ==0.0.0.1, - active ==0.1.0.17, - AC-Vector ==2.3.2, - ad ==4.2.1.1, - adjunctions ==4.2, - aeson ==0.8.0.2, - aeson-pretty ==0.7.2, - aeson-qq ==0.7.4, - aeson-utils ==0.2.2.1, - alarmclock ==0.2.0.5, - alex ==3.1.3, - amqp ==0.10.1, - ansi-terminal ==0.6.2.1, - ansi-wl-pprint ==0.6.7.1, - appar ==0.1.4, - approximate ==0.2.1.1, - arbtt ==0.8.1.4, - arithmoi ==0.4.1.1, - array installed, - arrow-list ==0.6.1.5, - asn1-data ==0.7.1, - asn1-encoding ==0.9.0, - asn1-parse ==0.9.0, - asn1-types ==0.3.0, - async ==2.0.2, - atto-lisp ==0.2.2, - attoparsec ==0.12.1.2, - attoparsec-conduit ==1.1.0, - attoparsec-enumerator ==0.3.3, - attoparsec-expr ==0.1.1.1, - authenticate ==1.3.2.11, - auto-update ==0.1.2.1, - aws ==0.11, - bake ==0.2, - bank-holidays-england ==0.1.0.1, - barecheck ==0.2.0.6, - base16-bytestring ==0.1.1.6, - base64-bytestring ==1.0.0.1, - base-compat ==0.5.0, - base-prelude ==0.1.8, - base-unicode-symbols ==0.2.2.4, - basic-prelude ==0.3.10, - bifunctors ==4.2, - binary installed, - binary-list ==1.0.1.0, - bindings-DSL ==1.0.21, - bioace ==0.0.1, - bioalign ==0.0.5, - biocore ==0.3.1, - biofasta ==0.0.3, - biofastq ==0.1, - biophd ==0.0.5, - biopsl ==0.4, - biosff ==0.3.7.1, - bits ==0.4, - BlastHTTP ==1.0.1, - blastxml ==0.3.2, - blaze-builder ==0.3.3.4, - blaze-builder-enumerator ==0.2.0.6, - blaze-html ==0.7.0.3, - blaze-markup ==0.6.1.1, - blaze-svg ==0.3.4, - blaze-textual ==0.2.0.9, - BlogLiterately ==0.7.1.7, - BlogLiterately-diagrams ==0.1.4.3, - bloodhound ==0.5.0.1, - bmp ==1.2.5.2, - Boolean ==0.2.3, - bool-extras ==0.4.0, - bound ==1.0.4, - BoundedChan ==1.0.3.0, - bson ==0.3.1, - bumper ==0.6.0.2, - byteable ==0.1.1, - bytedump ==1.0, - byteorder ==1.0.4, - bytes ==0.14.1.2, - bytestring installed, - bytestring-builder ==0.10.4.0.1, - bytestring-lexing ==0.4.3.2, - bytestring-mmap ==0.2.2, - bytestring-progress ==1.0.3, - bytestring-trie ==0.2.4, - bzlib ==0.5.0.4, - bzlib-conduit ==0.2.1.3, - c2hs ==0.20.1, - Cabal installed, - cabal-install ==1.18.0.6, - cabal-src ==0.2.5, - cairo ==0.13.0.5, - case-insensitive ==1.2.0.3, - cases ==0.1.2, - cassava ==0.4.2.1, - cautious-file ==1.0.2, - cereal ==0.4.1.0, - cereal-conduit ==0.7.2.3, - certificate ==1.3.9, - charset ==0.3.7, - Chart ==1.3.2, - Chart-diagrams ==1.3.2, - ChasingBottoms ==1.3.0.8, - check-email ==1.0, - checkers ==0.4.1, - chell ==0.4, - chell-quickcheck ==0.2.4, - chunked-data ==0.1.0.1, - cipher-aes ==0.2.9, - cipher-blowfish ==0.0.3, - cipher-camellia ==0.0.2, - cipher-des ==0.0.6, - cipher-rc4 ==0.1.4, - circle-packing ==0.1.0.3, - classy-prelude ==0.10.2, - classy-prelude-conduit ==0.10.2, - classy-prelude-yesod ==0.10.2, - clientsession ==0.9.1.1, - clock ==0.4.1.3, - cmdargs ==0.10.12, - code-builder ==0.1.3, - colour ==2.3.3, - comonad ==4.2.2, - comonads-fd ==4.0, - comonad-transformers ==4.0, - compdata ==0.9, - compensated ==0.6.1, - composition ==1.0.1.0, - compressed ==3.10, - concatenative ==1.0.1, - concurrent-extra ==0.7.0.9, - concurrent-supply ==0.1.7, - cond ==0.4.1.1, - conduit ==1.2.3.1, - conduit-combinators ==0.3.0.5, - conduit-extra ==1.1.5.1, - configurator ==0.3.0.0, - connection ==0.2.3, - constraints ==0.4.1.1, - containers installed, - containers-unicode-symbols ==0.3.1.1, - contravariant ==1.2, - control-monad-free ==0.5.3, - control-monad-loop ==0.1, - convertible ==1.1.0.0, - cookie ==0.4.1.4, - courier ==0.1.0.15, - cpphs ==1.18.6, - cprng-aes ==0.6.1, - cpu ==0.1.2, - criterion ==1.0.2.0, - crypto-api ==0.13.2, - cryptocipher ==0.6.2, - crypto-cipher-tests ==0.0.11, - crypto-cipher-types ==0.0.9, - cryptohash ==0.11.6, - cryptohash-conduit ==0.1.1, - cryptohash-cryptoapi ==0.1.3, - crypto-numbers ==0.2.3, - crypto-pubkey ==0.2.6, - crypto-pubkey-types ==0.4.2.3, - crypto-random ==0.0.8, - crypto-random-api ==0.2.0, - css-text ==0.1.2.1, - csv ==0.1.2, - csv-conduit ==0.6.3, - curl ==1.3.8, - data-accessor ==0.2.2.6, - data-accessor-mtl ==0.2.0.4, - data-binary-ieee754 ==0.4.4, - data-default ==0.5.3, - data-default-class ==0.0.1, - data-default-instances-base ==0.0.1, - data-default-instances-containers ==0.0.1, - data-default-instances-dlist ==0.0.1, - data-default-instances-old-locale ==0.0.1, - data-inttrie ==0.1.0, - data-lens-light ==0.1.2.1, - data-memocombinators ==0.5.1, - data-reify ==0.6, - DAV ==1.0.3, - deepseq installed, - deepseq-generics ==0.1.1.2, - derive ==2.5.18, - diagrams ==1.2, - diagrams-builder ==0.6.0.2, - diagrams-cairo ==1.2.0.4, - diagrams-contrib ==1.1.2.4, - diagrams-core ==1.2.0.4, - diagrams-haddock ==0.2.2.12, - diagrams-lib ==1.2.0.7, - diagrams-postscript ==1.1.0.3, - diagrams-svg ==1.1.0.3, - Diff ==0.3.0, - digest ==0.0.1.2, - digestive-functors ==0.7.1.3, - dimensional ==0.13.0.1, - directory installed, - directory-tree ==0.12.0, - direct-sqlite ==2.3.14, - distributed-process ==0.5.3, - distributed-process-async ==0.2.0, - distributed-process-client-server ==0.1.1, - distributed-process-execution ==0.1.0, - distributed-process-extras ==0.1.1, - distributed-process-simplelocalnet ==0.2.2.0, - distributed-process-supervisor ==0.1.1, - distributed-process-task ==0.1.0, - distributed-static ==0.3.1.0, - distributive ==0.4.4, - djinn-ghc ==0.0.2.2, - djinn-lib ==0.0.1.2, - dlist ==0.7.1, - dlist-instances ==0.1, - doctest ==0.9.11.1, - double-conversion ==2.0.1.0, - dual-tree ==0.2.0.5, - easy-file ==0.2.0, - either ==4.3.2.1, - elm-build-lib ==0.14.0.0, - elm-compiler ==0.14, - elm-core-sources ==1.0.0, - elm-package ==0.2.2, - email-validate ==2.0.1, - enclosed-exceptions ==1.0.1, - entropy ==0.3.4.1, - enumerator ==0.4.20, - eq ==4.0.3, - erf ==2.0.0.0, - errorcall-eq-instance ==0.1.0, - errors ==1.4.7, - ersatz ==0.2.6.1, - esqueleto ==2.1.2.1, - exceptions ==0.6.1, - exception-transformers ==0.3.0.4, - executable-path ==0.0.3, - ex-pool ==0.2, - extensible-exceptions ==0.1.1.4, - extra ==1.0, - failure ==0.2.0.3, - fast-logger ==2.2.3, - fay ==0.21.2.1, - fay-base ==0.19.4.1, - fay-builder ==0.2.0.1, - fay-dom ==0.5, - fay-jquery ==0.6.0.2, - fay-text ==0.3.2, - fay-uri ==0.2.0.0, - fb ==1.0.7, - fb-persistent ==0.3.4, - fclabels ==2.0.2, - FenwickTree ==0.1.1, - fgl ==5.5.0.1, - file-embed ==0.0.7, - file-location ==0.4.5.3, - filemanip ==0.3.6.2, - filepath installed, - fingertree ==0.1.0.0, - fixed ==0.2.1, - fixed-list ==0.1.5, - flexible-defaults ==0.0.1.1, - focus ==0.1.3, - foldl ==1.0.7, - force-layout ==0.3.0.8, - foreign-store ==0.1, - formatting ==6.0.0, - fpco-api ==1.2.0.4, - free ==4.10.0.1, - freenect ==1.2, - frisby ==0.2, - fsnotify ==0.1.0.3, - fuzzcheck ==0.1.1, - gd ==3000.7.3, - generic-aeson ==0.2.0.2, - generic-deriving ==1.6.3, - generics-sop ==0.1.0.4, - ghc-heap-view ==0.5.3, - ghcid ==0.3.3, - ghc-mod ==5.2.1.1, - ghc-mtl ==1.2.1.0, - ghc-paths ==0.1.0.9, - ghc-prim installed, - ghc-syb-utils ==0.2.2, - gio ==0.13.0.3, - git-embed ==0.1.0, - gl ==0.6.2, - glib ==0.13.0.6, - Glob ==0.7.5, - GLURaw ==1.4.0.1, - GLUT ==2.5.1.1, - graph-core ==0.2.1.0, - graphs ==0.5.0.1, - graphviz ==2999.17.0.1, - gravatar ==0.6, - groundhog ==0.7.0.1, - groundhog-mysql ==0.7.0.1, - groundhog-postgresql ==0.7.0.1, - groundhog-sqlite ==0.7.0.1, - groundhog-th ==0.7.0, - groupoids ==4.0, - groups ==0.4.0.0, - gtk ==0.13.3, - gtk2hs-buildtools ==0.13.0.3, - haddock-api ==2.15.0.1, - haddock-library ==1.1.1, - half ==0.2.0.1, - HandsomeSoup ==0.3.5, - happstack-server ==7.3.9, - happy ==1.19.4, - hashable ==1.2.3.1, - hashable-extras ==0.2.0.1, - hashmap ==1.3.0.1, - hashtables ==1.2.0.1, - haskeline installed, - haskell2010 installed, - haskell98 installed, - haskell-lexer ==1.0, - haskell-names ==0.4.1, - haskell-packages ==0.2.4.3, - haskell-src ==1.0.1.6, - haskell-src-exts ==1.16.0.1, - haskell-src-meta ==0.6.0.8, - hasql ==0.4.1, - hasql-backend ==0.2.2, - hasql-postgres ==0.9.1, - hastache ==0.6.1, - HaTeX ==3.16.0.0, - HaXml ==1.24.1, - haxr ==3000.10.3.1, - HCodecs ==0.5, - hdaemonize ==0.5.0.0, - hdevtools ==0.1.0.6, - heaps ==0.3.1, - hebrew-time ==0.1.1, - heist ==0.14.0.1, - here ==1.2.6, - heredoc ==0.2.0.0, - highlighting-kate ==0.5.11.1, - hinotify ==0.3.7, - hint ==0.4.2.1, - histogram-fill ==0.8.3.0, - hit ==0.6.2, - hjsmin ==0.1.4.7, - hledger ==0.23.3, - hledger-lib ==0.23.3, - hlibgit2 ==0.18.0.13, - hlint ==1.9.13, - hmatrix ==0.16.1.2, - hmatrix-gsl ==0.16.0.2, - holy-project ==0.1.1.1, - hoogle ==4.2.36, - hoopl installed, - hOpenPGP ==1.11, - hopenpgp-tools ==0.13, - hostname ==1.0, - hostname-validate ==1.0.0, - hourglass ==0.2.6, - hpc installed, - hPDB ==1.2.0, - hPDB-examples ==1.1.2, - hs-bibutils ==5.5, - hscolour ==1.20.3, - hse-cpp ==0.1, - hslogger ==1.2.6, - hslua ==0.3.13, - hspec ==2.1.2, - hspec2 ==0.6.1, - hspec-core ==2.1.2, - hspec-discover ==2.1.2, - hspec-expectations ==0.6.1, - hspec-meta ==2.0.0, - hspec-wai ==0.6.2, - hspec-wai-json ==0.6.0, - HStringTemplate ==0.7.3, - hsyslog ==2.0, - HTF ==0.12.2.3, - html ==1.0.1.2, - html-conduit ==1.1.1.1, - HTTP ==4000.2.19, - http-client ==0.4.6.1, - http-client-tls ==0.2.2, - http-conduit ==2.1.5, - http-date ==0.0.4, - http-reverse-proxy ==0.4.1.2, - http-types ==0.8.5, - HUnit ==1.2.5.2, - hweblib ==0.6.3, - hxt ==9.3.1.10, - hxt-charproperties ==9.2.0.0, - hxt-http ==9.1.5, - hxt-pickle-utils ==0.1.0.2, - hxt-regex-xmlschema ==9.2.0, - hxt-relaxng ==9.1.5.1, - hxt-unicode ==9.0.2.2, - hybrid-vectors ==0.1.2, - hyphenation ==0.4, - idna ==0.3.0, - ieee754 ==0.7.4, - imagesize-conduit ==1.0.0.4, - immortal ==0.2, - incremental-parser ==0.2.3.3, - indents ==0.3.3, - ini ==0.2.2, - integer-gmp installed, - integration ==0.2.0.1, - interpolate ==0.1.0, - interpolatedstring-perl6 ==0.9.0, - intervals ==0.7.0.1, - io-choice ==0.0.5, - io-manager ==0.1.0.2, - io-memoize ==1.1.1.0, - iproute ==1.3.1, - iterable ==3.0, - ixset ==1.0.6, - js-flot ==0.8.3, - js-jquery ==1.11.1, - json-schema ==0.7.3.0, - JuicyPixels ==3.1.7.1, - JuicyPixels-repa ==0.7, - kan-extensions ==4.1.1, - kdt ==0.2.2, - keter ==1.3.7.1, - keys ==3.10.1, - kure ==2.4.10, - language-c ==0.4.7, - language-ecmascript ==0.16.2, - language-glsl ==0.1.1, - language-haskell-extract ==0.2.4, - language-java ==0.2.7, - language-javascript ==0.5.13, - lazy-csv ==0.5, - lca ==0.2.4, - lens ==4.6.0.1, - lens-aeson ==1.0.0.3, - lens-family-th ==0.4.0.0, - lhs2tex ==1.18.1, - libgit ==0.3.0, - libnotify ==0.1.1.0, - lifted-async ==0.2.0.2, - lifted-base ==0.2.3.3, - linear ==1.15.5, - linear-accelerate ==0.2, - list-t ==0.3.1, - loch-th ==0.2.1, - log-domain ==0.9.3, - logfloat ==0.12.1, - logict ==0.6.0.2, - loop ==0.2.0, - lucid ==2.5, - machines ==0.4.1, - mandrill ==0.1.1.0, - map-syntax ==0.2, - markdown ==0.1.13, - markdown-unlit ==0.2.0.1, - math-functions ==0.1.5.2, - matrix ==0.3.4.0, - MaybeT ==0.1.2, - MemoTrie ==0.6.2, - mersenne-random-pure64 ==0.2.0.4, - messagepack ==0.3.0, - messagepack-rpc ==0.1.0.3, - mime-mail ==0.4.6.2, - mime-mail-ses ==0.3.2.1, - mime-types ==0.1.0.5, - missing-foreign ==0.1.1, - MissingH ==1.3.0.1, - mmap ==0.5.9, - mmorph ==1.0.4, - MonadCatchIO-transformers ==0.3.1.3, - monad-control ==0.3.3.0, - monad-coroutine ==0.8.0.1, - monadcryptorandom ==0.6.1, - monad-extras ==0.5.9, - monadic-arrays ==0.2.1.3, - monad-journal ==0.6.0.2, - monad-logger ==0.3.11.1, - monad-loops ==0.4.2.1, - monad-par ==0.3.4.7, - monad-parallel ==0.7.1.3, - monad-par-extras ==0.3.3, - monad-primitive ==0.1, - monad-products ==4.0.0.1, - MonadPrompt ==1.0.0.5, - MonadRandom ==0.3.0.1, - monad-st ==0.2.4, - monads-tf ==0.1.0.2, - mongoDB ==2.0.3, - monoid-extras ==0.3.3.5, - monoid-subclasses ==0.3.6.2, - mono-traversable ==0.7.0, - mtl ==2.1.3.1, - mtlparse ==0.1.2, - mtl-prelude ==1.0.1, - multimap ==1.2.1, - multipart ==0.1.2, - MusicBrainz ==0.2.2, - mwc-random ==0.13.2.2, - mysql ==0.1.1.7, - mysql-simple ==0.2.2.4, - nanospec ==0.2.0, - nats ==1, - neat-interpolation ==0.2.2, - nettle ==0.1.0, - network ==2.6.0.2, - network-conduit-tls ==1.1.0.2, - network-info ==0.2.0.5, - network-multicast ==0.0.11, - network-simple ==0.4.0.2, - network-transport ==0.4.1.0, - network-transport-tcp ==0.4.1, - network-transport-tests ==0.2.1.0, - network-uri ==2.6.0.1, - newtype ==0.2, - nsis ==0.2.4, - numbers ==3000.2.0.1, - numeric-extras ==0.0.3, - NumInstances ==1.4, - numtype ==1.1, - Octree ==0.5.3, - old-locale installed, - old-time installed, - OneTuple ==0.2.1, - opaleye ==0.3, - OpenGL ==2.9.2.0, - OpenGLRaw ==1.5.0.0, - openpgp-asciiarmor ==0.1, - operational ==0.2.3.2, - options ==1.2.1, - optparse-applicative ==0.11.0.1, - osdkeys ==0.0, - pandoc ==1.13.2, - pandoc-citeproc ==0.6, - pandoc-types ==1.12.4.1, - pango ==0.13.0.4, - parallel ==3.2.0.5, - parallel-io ==0.3.3, - parseargs ==0.1.5.2, - parsec ==3.1.7, - parsers ==0.12.1.1, - partial-handler ==0.1.0, - path-pieces ==0.1.5, - patience ==0.1.1, - pcre-light ==0.4.0.3, - pdfinfo ==1.5.1, - pem ==0.2.2, - persistent ==2.1.1.3, - persistent-mongoDB ==2.1.2, - persistent-mysql ==2.1.2, - persistent-postgresql ==2.1.2, - persistent-sqlite ==2.1.1.2, - persistent-template ==2.1.0.1, - phantom-state ==0.2.0.2, - pipes ==4.1.4, - pipes-concurrency ==2.0.2, - pipes-parse ==3.0.2, - placeholders ==0.1, - pointed ==4.1.1, - polyparse ==1.9, - pool-conduit ==0.1.2.3, - postgresql-binary ==0.5.0, - postgresql-libpq ==0.9.0.1, - postgresql-simple ==0.4.8.0, - pqueue ==1.2.1, - prefix-units ==0.1.0.2, - prelude-extras ==0.4, - present ==2.2, - pretty installed, - prettyclass ==1.0.0.0, - pretty-class ==1.0.1.1, - pretty-show ==1.6.8, - primes ==0.2.1.0, - primitive ==0.5.4.0, - process installed, - process-conduit ==1.2.0.1, - process-extras ==0.2.0, - product-profunctors ==0.6, - profunctor-extras ==4.0, - profunctors ==4.3.2, - project-template ==0.1.4.2, - publicsuffixlist ==0.1, - punycode ==2.0, - pure-io ==0.2.1, - pureMD5 ==2.1.2.1, - pwstore-fast ==2.4.4, - quandl-api ==0.2.0.0, - QuasiText ==0.1.2.5, - QuickCheck ==2.7.6, - quickcheck-assertions ==0.1.1, - quickcheck-instances ==0.3.9, - quickcheck-io ==0.1.1, - quickpull ==0.4.0.0, - rainbow ==0.20.0.4, - rainbow-tests ==0.20.0.4, - random ==1.0.1.1, - random-fu ==0.2.6.1, - random-shuffle ==0.0.4, - random-source ==0.3.0.6, - rank1dynamic ==0.2.0.1, - raw-strings-qq ==1.0.2, - ReadArgs ==1.2.2, - reducers ==3.10.3, - reflection ==1.5.1, - regex-applicative ==0.3.0.3, - regex-base ==0.93.2, - regex-compat ==0.95.1, - regex-pcre-builtin ==0.94.4.8.8.35, - regex-posix ==0.95.2, - regexpr ==0.5.4, - regex-tdfa ==1.2.0, - regex-tdfa-rc ==1.1.8.3, - regular ==0.3.4.3, - regular-xmlpickler ==0.2, - rematch ==0.2.0.0, - repa ==3.3.1.2, - repa-algorithms ==3.3.1.2, - repa-devil ==0.3.2.2, - repa-io ==3.3.1.2, - reroute ==0.2.2.1, - resource-pool ==0.2.3.2, - resourcet ==1.1.3.3, - rest-client ==0.4.0.2, - rest-core ==0.33.1.2, - rest-gen ==0.16.1.3, - rest-happstack ==0.2.10.3, - rest-snap ==0.1.17.14, - rest-stringmap ==0.2.0.2, - rest-types ==1.11.1.1, - rest-wai ==0.1.0.4, - rev-state ==0.1, - rfc5051 ==0.1.0.3, - runmemo ==1.0.0.1, - rvar ==0.2.0.2, - safe ==0.3.8, - safecopy ==0.8.3, - scientific ==0.3.3.3, - scotty ==0.9.0, - scrobble ==0.2.1.1, - securemem ==0.1.4, - semigroupoid-extras ==4.0, - semigroupoids ==4.2, - semigroups ==0.16.0.1, - sendfile ==0.7.9, - seqloc ==0.6, - setenv ==0.1.1.2, - SHA ==1.6.4.1, - shake ==0.14.2, - shake-language-c ==0.6.3, - shakespeare ==2.0.2.1, - shakespeare-i18n ==1.1.0, - shakespeare-text ==1.1.0, - shell-conduit ==4.5, - shelly ==1.5.6, - silently ==1.2.4.1, - simple-reflect ==0.3.2, - simple-sendfile ==0.2.18, - singletons ==1.0, - siphash ==1.0.3, - skein ==1.0.9.2, - slave-thread ==0.1.5, - smallcheck ==1.1.1, - smtLib ==1.0.7, - snap ==0.13.3.2, - snap-core ==0.9.6.4, - snaplet-fay ==0.3.3.8, - snap-server ==0.9.4.6, - socks ==0.5.4, - sodium ==0.11.0.2, - sourcemap ==0.1.3.0, - speculation ==1.5.0.1, - sphinx ==0.6.0.1, - split ==0.2.2, - Spock ==0.7.5.1, - spoon ==0.3.1, - sqlite-simple ==0.4.8.0, - stateref ==0.3, - statestack ==0.2.0.3, - statistics ==0.13.2.1, - statistics-linreg ==0.3, - stm ==2.4.4, - stm-chans ==3.0.0.2, - stm-conduit ==2.5.2, - stm-containers ==0.2.7, - stm-stats ==0.2.0.0, - storable-complex ==0.2.1, - storable-endian ==0.2.5, - streaming-commons ==0.1.8, - streams ==3.2, - strict ==0.3.2, - stringable ==0.1.3, - stringbuilder ==0.5.0, - stringprep ==1.0.0, - stringsearch ==0.3.6.5, - stylish-haskell ==0.5.11.0, - SVGFonts ==1.4.0.3, - syb ==0.4.2, - syb-with-class ==0.6.1.5, - system-canonicalpath ==0.2.0.0, - system-fileio ==0.3.16, - system-filepath ==0.4.13, - system-posix-redirect ==1.1.0.1, - tabular ==0.2.2.5, - tagged ==0.7.3, - tagshare ==0.0, - tagsoup ==0.13.3, - tagstream-conduit ==0.5.5.3, - tar ==0.4.0.1, - tardis ==0.3.0.0, - tasty ==0.10.1, - tasty-ant-xml ==1.0.1, - tasty-golden ==2.2.2.4, - tasty-hunit ==0.9.0.1, - tasty-quickcheck ==0.8.3.2, - tasty-smallcheck ==0.8.0.1, - tasty-th ==0.1.3, - template-haskell installed, - temporary ==1.2.0.3, - temporary-rc ==1.2.0.3, - terminal-progress-bar ==0.0.1.4, - terminal-size ==0.3.0, - terminfo installed, - test-framework ==0.8.1.0, - test-framework-hunit ==0.3.0.1, - test-framework-quickcheck2 ==0.3.0.3, - test-framework-th ==0.2.4, - testing-feat ==0.4.0.2, - testpack ==2.1.3.0, - texmath ==0.8.0.1, - text ==1.1.1.3, - text-binary ==0.1.0, - text-format ==0.3.1.1, - text-icu ==0.7.0.0, - tf-random ==0.5, - th-desugar ==1.4.2, - th-expand-syns ==0.3.0.4, - th-extras ==0.0.0.2, - th-lift ==0.7, - th-orphans ==0.8.2, - threads ==0.5.1.2, - th-reify-many ==0.1.2, - thyme ==0.3.5.5, - time installed, - time-compat ==0.1.0.3, - time-lens ==0.4.0.1, - timezone-olson ==0.1.6, - timezone-series ==0.1.4, - tls ==1.2.13, - tls-debug ==0.3.4, - tostring ==0.2.1, - transformers installed, - transformers-base ==0.4.3, - transformers-compat ==0.3.3.3, - traverse-with-class ==0.2.0.3, - tree-view ==0.4, - tuple ==0.3.0.2, - type-eq ==0.4.2, - type-list ==0.0.0.0, - udbus ==0.2.1, - unbounded-delays ==0.1.0.8, - union-find ==0.2, - uniplate ==1.6.12, - unix installed, - unix-compat ==0.4.1.3, - unix-time ==0.3.4, - unordered-containers ==0.2.5.1, - uri-encode ==1.5.0.3, - url ==2.1.3, - utf8-light ==0.4.2, - utf8-string ==0.3.8, - uuid ==1.3.7, - vault ==0.3.0.4, - vector ==0.10.12.2, - vector-algorithms ==0.6.0.3, - vector-binary-instances ==0.2.1.0, - vector-instances ==3.3, - vector-space ==0.8.7, - vector-space-points ==0.2, - vector-th-unbox ==0.2.1.0, - vhd ==0.2.2, - void ==0.7, - wai ==3.0.2.1, - wai-app-static ==3.0.0.5, - wai-conduit ==3.0.0.2, - wai-eventsource ==3.0.0, - wai-extra ==3.0.3.1, - wai-logger ==2.2.3, - wai-middleware-static ==0.6.0.1, - wai-websockets ==3.0.0.3, - warp ==3.0.4.1, - warp-tls ==3.0.1.1, - webdriver ==0.6.0.3, - web-fpco ==0.1.1.0, - websockets ==0.9.2.1, - wizards ==1.0.1, - wl-pprint ==1.1, - wl-pprint-extras ==3.5.0.3, - wl-pprint-terminfo ==3.7.1.3, - wl-pprint-text ==1.1.0.2, - word8 ==0.1.1, - X11 ==1.6.1.2, - x509 ==1.5.0.1, - x509-store ==1.5.0, - x509-system ==1.5.0, - x509-validation ==1.5.1, - xenstore ==0.1.1, - xhtml installed, - xml ==1.3.13, - xml-conduit ==1.2.3.1, - xmlgen ==0.6.2.1, - xml-hamlet ==0.4.0.9, - xmlhtml ==0.2.3.3, - xml-types ==0.3.4, - xss-sanitize ==0.3.5.4, - yackage ==0.7.0.6, - yaml ==0.8.10.1, - Yampa ==0.9.6, - YampaSynth ==0.2, - yesod ==1.4.1.3, - yesod-auth ==1.4.1.1, - yesod-auth-deskcom ==1.4.0, - yesod-auth-fb ==1.6.6, - yesod-auth-hashdb ==1.4.1.1, - yesod-bin ==1.4.3.1, - yesod-core ==1.4.7.1, - yesod-eventsource ==1.4.0.1, - yesod-fay ==0.7.0, - yesod-fb ==0.3.4, - yesod-form ==1.4.3.1, - yesod-gitrepo ==0.1.1.0, - yesod-newsfeed ==1.4.0.1, - yesod-persistent ==1.4.0.2, - yesod-sitemap ==1.4.0.1, - yesod-static ==1.4.0.4, - yesod-test ==1.4.2.1, - yesod-text-markdown ==0.1.7, - yesod-websockets ==0.2.1.1, - zeromq4-haskell ==0.6.2, - zip-archive ==0.2.3.5, - zlib ==0.5.4.2, - zlib-bindings ==0.1.1.5, - zlib-enum ==0.2.3.1, - zlib-lens ==0.1 diff --git a/debian-bootstrap.sh b/debian-bootstrap.sh deleted file mode 100755 index 827e8460..00000000 --- a/debian-bootstrap.sh +++ /dev/null @@ -1,71 +0,0 @@ -#!/bin/bash -ex - -# Work in progress: create a list of commands necessary to get Stackage -# up-and-running on a freshly installed Debian-based system (includin Ubuntu). - -# Quick start: -# wget -O - https://raw.github.com/fpco/stackage/master/debian-bootstrap.sh | bash -ex - -# NOTE: Requires that GHC and Cabal are installed and on your PATH. For -# instructions, see: -# http://www.stackage.org/install - -add-apt-repository -y ppa:chris-lea/zeromq -add-apt-repository -y ppa:floe/libtisch -add-apt-repository -y ppa:zoogie/sdl2-snapshots -apt-get update -apt-get install -y \ - build-essential \ - libncurses-dev \ - git \ - wget \ - m4 \ - texlive-full \ - libgmp3c2 \ - libgmp3-dev \ - zlib1g-dev \ - libedit2 \ - libedit-dev \ - freeglut3-dev \ - libglu1-mesa-dev \ - libglib2.0-dev \ - libcairo2-dev \ - libpango1.0-dev \ - libgtk2.0-dev \ - zip \ - libdevil-dev \ - llvm \ - libbz2-dev \ - libjudy-dev \ - libsqlite3-dev \ - libmysqlclient-dev \ - libpq-dev \ - libicu-dev \ - libssl-dev \ - libgsl0-dev \ - libblas-dev \ - liblapack-dev \ - libcurl4-openssl-dev \ - libfreenect-dev \ - libnotify-dev \ - libgd2-xpm-dev \ - libyaml-dev \ - liblzma-dev \ - libsdl2-dev \ - libxss-dev \ - libzmq3-dev - -mkdir /tmp/nettle-build -( -cd /tmp/nettle-build -wget https://ftp.gnu.org/gnu/nettle/nettle-2.7.1.tar.gz -tar zxf nettle-2.7.1.tar.gz -cd nettle-2.7.1 -./configure --prefix=/usr -make -make install - -mkdir -p /usr/lib/x86_64-linux-gnu/ -ln -sfv /usr/lib/libnettle.so.4.7 /usr/lib/x86_64-linux-gnu/libnettle.so.4 -) -rm -rf /tmp/nettle-build diff --git a/stackage.cabal b/stackage.cabal deleted file mode 100644 index d12c172b..00000000 --- a/stackage.cabal +++ /dev/null @@ -1,105 +0,0 @@ -name: stackage -version: 0.6.0.1 -synopsis: "Stable Hackage," tools for creating a vetted set of packages from Hackage. -description: Please see for a description and documentation. -homepage: https://github.com/fpco/stackage -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 - 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 diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 index a824f8c3..00000000 --- a/test/Spec.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Stackage/BuildPlanSpec.hs b/test/Stackage/BuildPlanSpec.hs deleted file mode 100644 index b87c74d2..00000000 --- a/test/Stackage/BuildPlanSpec.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-} -module Stackage.BuildPlanSpec (spec) where - -import qualified Data.Map as Map -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Data.Yaml -import qualified Data.Yaml as Y -import Distribution.Version -import Network.HTTP.Client -import Network.HTTP.Client.TLS (tlsManagerSettings) -import Stackage.BuildConstraints -import Stackage.BuildPlan -import Stackage.CheckBuildPlan -import Stackage.PackageDescription -import Stackage.Prelude -import Stackage.UpdateBuildPlan -import Test.Hspec - -spec :: Spec -spec = do - it "simple package set" $ check testBuildConstraints $ makePackageSet - [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])]) - ,("bar", [0, 0, 0], [])] - it "bad version range on depdendency fails" $ badBuildPlan $ makePackageSet - [("foo", [0, 0, 0], [("bar", thisV [1, 1, 0])]) - ,("bar", [0, 0, 0], [])] - it "nonexistent package fails to check" $ badBuildPlan $ makePackageSet - [("foo", [0, 0, 0], [("nonexistent", thisV [0, 0, 0])]) - ,("bar", [0, 0, 0], [])] - it "mutual cycles fail to check" $ badBuildPlan $ makePackageSet - [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])]) - ,("bar", [0, 0, 0], [("foo", thisV [0, 0, 0])])] - it "nested cycles fail to check" $ badBuildPlan $ makePackageSet - [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])]) - ,("bar", [0, 0, 0], [("mu", thisV [0, 0, 0])]) - ,("mu", [0, 0, 0], [("foo", thisV [0, 0, 0])])] - {- Shouldn't be testing this actually - it "default package set checks ok" $ - check defaultBuildConstraints getLatestAllowedPlans - -} - --- | Checking should be considered a bad build plan. -badBuildPlan :: (BuildConstraints -> IO (Map PackageName PackagePlan)) - -> void - -> IO () -badBuildPlan m _ = do - mu <- try (check testBuildConstraints m) - case mu of - Left (_ :: BadBuildPlan) -> - return () - Right () -> - error "Expected bad build plan." - --- | Check build plan with the given package set getter. -check :: (Manager -> IO BuildConstraints) - -> (BuildConstraints -> IO (Map PackageName PackagePlan)) - -> IO () -check readPlanFile getPlans = withManager tlsManagerSettings $ \man -> do - bc <- readPlanFile man - plans <- getPlans bc - bp <- newBuildPlan plans bc - let bs = Y.encode bp - ebp' = Y.decodeEither bs - - bp' <- either error return ebp' - - let allPackages = Map.keysSet (bpPackages bp) ++ Map.keysSet (bpPackages bp') - forM_ allPackages $ \name -> - (name, lookup name (bpPackages bp')) `shouldBe` - (name, lookup name (bpPackages bp)) - bpGithubUsers bp' `shouldBe` bpGithubUsers bp - - when (bp' /= bp) $ error "bp' /= bp" - bp2 <- updateBuildPlan plans bp - when (dropVersionRanges bp2 /= dropVersionRanges bp) $ error "bp2 /= bp" - checkBuildPlan bp - where - dropVersionRanges bp = - bp { bpPackages = map go $ bpPackages bp } - where - go pb = pb { ppConstraints = go' $ ppConstraints pb } - go' pc = pc { pcVersionRange = anyVersion } - --- | Make a package set from a convenient data structure. -makePackageSet - :: [(String,[Int],[(String,VersionRange)])] - -> BuildConstraints - -> IO (Map PackageName PackagePlan) -makePackageSet ps _ = - return $ - M.fromList $ - map - (\(name,ver,deps) -> - ( PackageName name - , dummyPackage ver $ - M.fromList $ - map - (\(dname,dver) -> - ( PackageName dname - , DepInfo {diComponents = S.fromList - [CompLibrary] - ,diRange = dver})) - deps)) - ps - where - dummyPackage v deps = - PackagePlan - {ppVersion = Version v [] - ,ppGithubPings = mempty - ,ppUsers = mempty - ,ppConstraints = - PackageConstraints - {pcVersionRange = anyV - ,pcMaintainer = Nothing - ,pcTests = Don'tBuild - ,pcHaddocks = Don'tBuild - ,pcBuildBenchmarks = False - ,pcFlagOverrides = mempty - ,pcEnableLibProfile = False} - ,ppDesc = - SimpleDesc - {sdPackages = deps - ,sdTools = mempty - ,sdProvidedExes = mempty - ,sdModules = mempty}} - --- | This exact version is required. -thisV :: [Int] -> VersionRange -thisV ver = thisVersion (Version ver []) - --- | Accept any version. -anyV :: VersionRange -anyV = anyVersion - --- | Test plan. -testBuildConstraints :: void -> IO BuildConstraints -testBuildConstraints _ = - decodeFileEither - (fpToString fp) >>= - either throwIO toBC - where fp = "test/test-build-constraints.yaml" diff --git a/test/Stackage/CorePackagesSpec.hs b/test/Stackage/CorePackagesSpec.hs deleted file mode 100644 index ce0c5d10..00000000 --- a/test/Stackage/CorePackagesSpec.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-} -module Stackage.CorePackagesSpec (spec) where - -import Stackage.CorePackages -import Stackage.Prelude -import Test.Hspec - -spec :: Spec -spec = do - it "works" $ void getCorePackages - it "contains known core packages" $ do - m <- getCorePackages - forM_ (words "ghc containers base") $ \p -> - m `shouldSatisfy` (member (PackageName p)) - it "getCoreExecutables includes known executables" $ do - s <- getCoreExecutables - s `shouldSatisfy` member "ghc" - s `shouldSatisfy` member "hsc2hs" - s `shouldSatisfy` member "runghc" diff --git a/test/Stackage/PackageIndexSpec.hs b/test/Stackage/PackageIndexSpec.hs deleted file mode 100644 index e0ef97e6..00000000 --- a/test/Stackage/PackageIndexSpec.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-} -module Stackage.PackageIndexSpec (spec) where - -import Stackage.PackageIndex -import Stackage.Prelude -import Test.Hspec -import Distribution.Package (packageId) - -spec :: Spec -spec = do - it "works" $ (runResourceT $ sourcePackageIndex $$ sinkNull :: IO ()) - it "getLatestDescriptions gives reasonable results" $ do - let f x y = (display x, display y) `member` asSet (setFromList - [ (asText "base", asText "4.5.0.0") - , ("does-not-exist", "9999999999999999999") - ]) - m <- getLatestDescriptions f return - length m `shouldBe` 1 - p <- simpleParse $ asText "base" - v <- simpleParse $ asText "4.5.0.0" - (pkgVersion . packageId <$> m) `shouldBe` singletonMap p v diff --git a/test/test-build-constraints.yaml b/test/test-build-constraints.yaml deleted file mode 100644 index de831eaf..00000000 --- a/test/test-build-constraints.yaml +++ /dev/null @@ -1,20 +0,0 @@ -packages: - "Test": - - foo - - bar - -global-flags: [] - -skipped-tests: [] -expected-test-failures: [] -expected-haddock-failures: [] -skipped-benchmarks: [] -skipped-profiling: [] - -github-users: - bar: - - demo - -package-flags: - foo: - demo: true