diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 00000000..101363c1 --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,3 @@ +((haskell-mode . ((haskell-process-type . cabal-repl) + (haskell-indent-spaces . 4) + (hindent-style . "johan-tibell")))) diff --git a/.dockerignore b/.dockerignore new file mode 100644 index 00000000..383463ca --- /dev/null +++ b/.dockerignore @@ -0,0 +1,8 @@ +dist +builds +logs +.cabal-sandbox +cabal.sandbox.config +tarballs +*.yaml +.git diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 00000000..7cf659d4 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,24 @@ +env: + - CABALVER=1.20 GHCVER=7.8.4 + +cache: + directories: + - $HOME/.ghc + - $HOME/.cabal + +# Note: the distinction between `before_install` and `install` is not important. +before_install: + - travis_retry sudo add-apt-repository -y ppa:hvr/ghc + - travis_retry sudo apt-get update + - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex + - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH + +install: + - cabal --version + - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" + - travis_retry cabal update + - cabal install -j + +# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail. +script: + - ./dist/build/stackage/stackage check diff --git a/ChangeLog.md b/ChangeLog.md index 37704fa8..3d7dd179 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,7 +1,28 @@ -## 0.4.0 +## Unreleased * 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. diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 00000000..c3956908 --- /dev/null +++ b/Dockerfile @@ -0,0 +1,25 @@ +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 013e3209..82a9802d 100644 --- a/README.md +++ b/README.md @@ -49,6 +49,28 @@ build by running: cabal install stackage stackage nightly +### Docker + +Note: This method is currently considered experimental. + +If you'd like to check a build plan, or perform an entire build, without +specially configuring your system, Docker may be a good approach. To check if +some modifications to `build-constraints.yaml` are valid, try the following: + +1. Create a local clone of the `stackage` repo +2. Make modifications to your local `build-constraints.yaml` +3. Inside the `stackage` working directory, run the following: + + ``` + $ docker run -it --rm -v $(pwd):/stackage -w /stackage snoyberg/stackage /bin/bash -c 'cabal update && stackage check' + ``` + +Similarly, if you'd like to perform an entire build, you can replace the last step with: + +``` +$ docker run -it --rm -v $(pwd):/stackage -w /stackage snoyberg/stackage /bin/bash -c 'cabal update && stackage nightly --skip-upload' +``` + ## Processing The following describes at a high level the series of steps for processing diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs index 94baca9e..c4ce1ceb 100644 --- a/Stackage/BuildConstraints.hs +++ b/Stackage/BuildConstraints.hs @@ -10,6 +10,9 @@ module Stackage.BuildConstraints , SystemInfo (..) , getSystemInfo , defaultBuildConstraints + , toBC + , BuildConstraintsSource (..) + , loadBuildConstraints ) where import Control.Monad.Writer.Strict (execWriter, tell) @@ -21,7 +24,7 @@ import Distribution.System (Arch, OS) import qualified Distribution.System import Distribution.Version (anyVersion) import Filesystem (isFile) -import Network.HTTP.Client (Manager, httpLbs, responseBody) +import Network.HTTP.Client (Manager, httpLbs, responseBody, Request) import Stackage.CorePackages import Stackage.Prelude @@ -88,12 +91,13 @@ data BuildConstraints = BuildConstraints } data PackageConstraints = PackageConstraints - { pcVersionRange :: VersionRange - , pcMaintainer :: Maybe Maintainer - , pcTests :: TestState - , pcHaddocks :: TestState - , pcBuildBenchmarks :: Bool - , pcFlagOverrides :: Map FlagName Bool + { pcVersionRange :: VersionRange + , pcMaintainer :: Maybe Maintainer + , pcTests :: TestState + , pcHaddocks :: TestState + , pcBuildBenchmarks :: Bool + , pcFlagOverrides :: Map FlagName Bool + , pcEnableLibProfile :: Bool } deriving (Show, Eq) instance ToJSON PackageConstraints where @@ -103,6 +107,7 @@ instance ToJSON PackageConstraints where , "haddocks" .= pcHaddocks , "build-benchmarks" .= pcBuildBenchmarks , "flags" .= Map.mapKeysWith const unFlagName pcFlagOverrides + , "library-profiling" .= pcEnableLibProfile ] where addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer @@ -115,6 +120,7 @@ instance FromJSON PackageConstraints where 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. @@ -122,15 +128,32 @@ instance FromJSON PackageConstraints where -- Checks the current directory for a build-constraints.yaml file and uses it -- if present. If not, downloads from Github. defaultBuildConstraints :: Manager -> IO BuildConstraints -defaultBuildConstraints man = do - e <- isFile fp - if e - then decodeFileEither (fpToString fp) >>= either throwIO toBC - else httpLbs req man >>= - either throwIO toBC . decodeEither' . toStrict . responseBody +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 - fp = "build-constraints.yaml" - req = "https://raw.githubusercontent.com/fpco/stackage/master/build-constraints.yaml" + 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 @@ -144,24 +167,24 @@ getSystemInfo = do siArch = Distribution.System.X86_64 data ConstraintFile = ConstraintFile - { cfGlobalFlags :: Map FlagName Bool - , cfPackageFlags :: Map PackageName (Map FlagName Bool) + { cfPackageFlags :: Map PackageName (Map FlagName Bool) , cfSkippedTests :: Set PackageName , cfExpectedTestFailures :: Set PackageName , cfExpectedHaddockFailures :: Set PackageName , cfSkippedBenchmarks :: Set PackageName , cfPackages :: Map Maintainer (Vector Dependency) , cfGithubUsers :: Map Text (Set Text) + , cfSkippedLibProfiling :: Set PackageName } instance FromJSON ConstraintFile where parseJSON = withObject "ConstraintFile" $ \o -> do - cfGlobalFlags <- goFlagMap <$> o .: "global-flags" cfPackageFlags <- (goPackageMap . fmap goFlagMap) <$> o .: "package-flags" cfSkippedTests <- getPackages o "skipped-tests" cfExpectedTestFailures <- getPackages o "expected-test-failures" cfExpectedHaddockFailures <- getPackages o "expected-haddock-failures" cfSkippedBenchmarks <- getPackages o "skipped-benchmarks" + cfSkippedLibProfiling <- getPackages o "skipped-profiling" cfPackages <- o .: "packages" >>= mapM (mapM toDep) . Map.mapKeysWith const Maintainer @@ -196,6 +219,7 @@ toBC ConstraintFile {..} = do 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 @@ -205,7 +229,6 @@ toBC ConstraintFile {..} = do | name `member` cfExpectedHaddockFailures = ExpectFailure | otherwise = ExpectSuccess - pcFlagOverrides = fromMaybe mempty (lookup name cfPackageFlags) ++ - cfGlobalFlags + pcFlagOverrides = fromMaybe mempty $ lookup name cfPackageFlags bcGithubUsers = cfGithubUsers diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs index 27868f06..b8bc5376 100644 --- a/Stackage/BuildPlan.hs +++ b/Stackage/BuildPlan.hs @@ -14,6 +14,7 @@ module Stackage.BuildPlan , PackagePlan (..) , newBuildPlan , makeToolMap + , getLatestAllowedPlans ) where import Control.Monad.State.Strict (execState, get, put) @@ -90,9 +91,9 @@ instance FromJSON PackagePlan where ppDesc <- o .: "description" return PackagePlan {..} -newBuildPlan :: MonadIO m => BuildConstraints -> m BuildPlan -newBuildPlan bc@BuildConstraints {..} = liftIO $ do - packagesOrig <- getLatestDescriptions (isAllowed bc) (mkPackagePlan bc) +-- | 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] @@ -205,3 +206,9 @@ mkPackagePlan bc gpd = do 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 index 1ad76b27..74bf3b83 100644 --- a/Stackage/CheckBuildPlan.hs +++ b/Stackage/CheckBuildPlan.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -7,28 +8,38 @@ -- | 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.Text as T +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 --- FIXME check cycles in dependencies, only looking at libraries and --- executables - -checkBuildPlan :: MonadThrow m => BuildPlan -> m () +-- | 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 = siCorePackages bpSystemInfo ++ map ppVersion bpPackages + 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 -checkDeps :: Map PackageName Version +-- | 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) = @@ -37,8 +48,16 @@ checkDeps allPackages (user, pb) = go (dep, diRange -> range) = case lookup dep allPackages of Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap - Just version - | version `withinRange` range -> return () + 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 @@ -51,6 +70,38 @@ checkDeps allPackages (user, 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 diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs index c1b087ac..80693dad 100644 --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -4,9 +4,14 @@ module Stackage.CompleteBuild ( BuildType (..) , BumpType (..) + , BuildFlags (..) , completeBuild , justCheck + , justUploadNightly ) 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) @@ -22,8 +27,20 @@ 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 + } deriving (Show) + data BuildType = Nightly | LTS BumpType deriving (Show, Read, Eq, Ord) @@ -39,28 +56,42 @@ data Settings = Settings , slug :: Text , setArgs :: Text -> UploadBundle -> UploadBundle , postBuild :: IO () + , distroName :: Text -- ^ distro name on Hackage } +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" + } + where + slug' = "nightly-" ++ day + getSettings :: Manager -> BuildType -> IO Settings getSettings man Nightly = do day <- tshow . utctDay <$> getCurrentTime - let slug' = "nightly-" ++ day - plan' <- defaultBuildConstraints man >>= newBuildPlan - return Settings - { planFile = fpFromText ("nightly-" ++ day) <.> "yaml" - , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day - , logDir = fpFromText $ "logs/stackage-nightly-" ++ day - , title = \ghcVer -> concat - [ "Stackage Nightly " - , day - , ", GHC " - , ghcVer - ] - , slug = slug' - , setArgs = \ghcVer ub -> ub { ubNightly = Just ghcVer } - , plan = plan' - , postBuild = return () - } + 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 "." @@ -72,21 +103,25 @@ getSettings man (LTS bumpType) = do case mlts of Nothing -> LTSVer 0 0 Just (LTSVer x _) -> LTSVer (x + 1) 0 - plan' <- defaultBuildConstraints man >>= newBuildPlan + 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 - plan' <- updateBuildPlan oldplan + 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/stackage-lts-" ++ tshow new + , buildDir = fpFromText $ "builds/lts" , logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new , title = \ghcVer -> concat [ "LTS Haskell " @@ -106,6 +141,7 @@ getSettings man (LTS bumpType) = do git ["commit", "-m", "Added new LTS release: " ++ show new] putStrLn "Pushing to Git repository" git ["push"] + , distroName = "LTSHaskell" } data LTSVer = LTSVer !Int !Int @@ -130,16 +166,27 @@ renderLTSVer lts = fpFromText $ concat , ".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 = withManager tlsManagerSettings $ \man -> do +justCheck = stillAlive $ withManager tlsManagerSettings $ \man -> do putStrLn "Loading build constraints" bc <- defaultBuildConstraints man putStrLn "Creating build plan" - plan <- newBuildPlan bc + plans <- getLatestAllowedPlans bc + plan <- newBuildPlan plans bc putStrLn $ "Writing build plan to check-plan.yaml" encodeFile "check-plan.yaml" plan @@ -149,37 +196,71 @@ justCheck = withManager tlsManagerSettings $ \man -> do putStrLn "Plan seems valid!" -completeBuild :: BuildType -> IO () -completeBuild buildType = withManager tlsManagerSettings $ \man -> do +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 + } + +-- | 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 {..} <- getSettings man buildType + settings@Settings {..} <- getSettings man buildType putStrLn $ "Writing build plan to: " ++ fpToText planFile encodeFile (fpToString planFile) plan - putStrLn "Checking build plan" - checkBuildPlan plan + if bfSkipCheck buildFlags + then putStrLn "Skipping build plan check" + else do + putStrLn "Checking build plan" + checkBuildPlan plan putStrLn "Performing build" - let pb = PerformBuild - { pbPlan = plan - , pbInstallDest = buildDir - , pbLogDir = logDir - , pbLog = hPut stdout - , pbJobs = 8 - , pbGlobalInstall = False - } - performBuild pb >>= mapM_ putStrLn + performBuild (getPerformBuild buildFlags settings) >>= mapM_ putStrLn + when (bfDoUpload buildFlags) $ + finallyUpload settings man + +justUploadNightly + :: Text -- ^ nightly date + -> IO () +justUploadNightly day = do + plan <- decodeFileEither (fpToString $ nightlyPlanFile day) + >>= either throwM return + withManager tlsManagerSettings $ finallyUpload $ nightlySettings day plan + +-- | The final part of the complete build process: uploading a bundle, +-- docs and a distro to hackage. +finallyUpload :: Settings -> Manager -> IO () +finallyUpload settings@Settings{..} man = do putStrLn "Uploading bundle to Stackage Server" - token <- readFile "/auth-token" + + mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN" + token <- + case mtoken of + Nothing -> decodeUtf8 <$> readFile "/auth-token" + Just token -> return $ pack token + now <- epochTime let ghcVer = display $ siGhcVersion $ bpSystemInfo plan (ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def { ubContents = serverBundle now (title ghcVer) slug plan - , ubAuthToken = decodeUtf8 token + , ubAuthToken = token } putStrLn $ "New ident: " ++ unSnapshotIdent ident forM_ mloc $ \loc -> @@ -190,7 +271,7 @@ completeBuild buildType = withManager tlsManagerSettings $ \man -> do putStrLn "Uploading docs to Stackage Server" res1 <- uploadDocs UploadDocs { udServer = def - , udAuthToken = decodeUtf8 token + , udAuthToken = token , udDocs = pbDocDir pb , udSnapshot = ident } man @@ -200,15 +281,17 @@ completeBuild buildType = withManager tlsManagerSettings $ \man -> do case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of [username, password] -> do putStrLn "Uploading as Hackage distro" - res2 <- uploadHackageDistro plan username password man + res2 <- uploadHackageDistroNamed distroName plan username password man putStrLn $ "Distro upload response: " ++ tshow res2 _ -> putStrLn "No creds found, skipping Hackage distro upload" putStrLn "Uploading doc map" uploadDocMap UploadDocMap { udmServer = def - , udmAuthToken = decodeUtf8 token + , udmAuthToken = token , udmSnapshot = ident , udmDocDir = pbDocDir pb , udmPlan = plan } man >>= print + where + pb = getPerformBuild (error "finallyUpload.buildFlags") settings diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs new file mode 100644 index 00000000..1e5171d8 --- /dev/null +++ b/Stackage/GhcPkg.hs @@ -0,0 +1,90 @@ +{-# 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 + -> IO (Set PackageName) -- ^ packages remaining in the database after cleanup +setupPackageDatabase mdb docDir log' toInstall = do + registered1 <- getRegisteredPackages flags + forM_ registered1 $ \pi@(PackageIdentifier name version) -> + case lookup name toInstall of + Just version' | version /= version' -> unregisterPackage log' docDir flags pi + _ -> return () + broken <- getBrokenPackages flags + forM_ broken $ unregisterPackage log' 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 + -> FilePath -- ^ doc directory + -> [String] -> PackageIdentifier -> IO () +unregisterPackage log' docDir flags ident@(PackageIdentifier name _) = do + log' $ "Unregistering " ++ encodeUtf8 (display ident) ++ "\n" + void (readProcessWithExitCode + "ghc-pkg" + ("unregister": flags ++ ["--force", unpack $ display name]) + "") + + void $ tryIO $ removeTree $ docDir fpFromText (display ident) diff --git a/Stackage/InstallBuild.hs b/Stackage/InstallBuild.hs new file mode 100644 index 00000000..757939a7 --- /dev/null +++ b/Stackage/InstallBuild.hs @@ -0,0 +1,100 @@ +{-# 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 + } 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 + } + +-- | 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/PerformBuild.hs b/Stackage/PerformBuild.hs index 5299f34e..db9d78d6 100644 --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -19,11 +19,12 @@ import qualified Data.Map as Map import Data.NonNull (fromNullable) import Filesystem (canonicalizePath, createTree, getWorkingDirectory, isDirectory, - removeTree, rename) + 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) @@ -61,6 +62,13 @@ data PerformBuild = PerformBuild , 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 } data PackageInfo = PackageInfo @@ -83,7 +91,9 @@ waitForDeps toolMap packageMap activeComps bp pi action = do case lookup exe toolMap >>= fromNullable . map checkPackage . setToList of Nothing | isCoreExe exe -> return () - | otherwise -> throwSTM $ ToolMissing exe + -- https://github.com/jgm/zip-archive/issues/23 + -- | otherwise -> throwSTM $ ToolMissing exe + | otherwise -> return () Just packages -> ofoldl1' (<|>) packages action where @@ -126,6 +136,10 @@ 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 @@ -153,12 +167,13 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do $ \ClosedStream Inherited Inherited -> return () let removeTree' fp = whenM (isDirectory fp) (removeTree fp) - mapM_ removeTree' [pbInstallDest, pbLogDir] + removeTree' pbLogDir - forM_ (pbDatabase pb) $ \db -> do - createTree $ parent db - withCheckedProcess (proc "ghc-pkg" ["init", fpToString db]) - $ \ClosedStream Inherited Inherited -> return () + 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) @@ -178,7 +193,14 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do env <- getEnvironment haddockFiles <- newTVarIO mempty - forM_ packageMap $ \pi -> void $ async $ singleBuild pb SingleBuild + registeredPackages <- setupPackageDatabase + (pbDatabase pb) + (pbDocDir pb) + pbLog + (ppVersion <$> bpPackages pbPlan) + + forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages + SingleBuild { sbSem = sem , sbErrsVar = errsVar , sbWarningsVar = warningsVar @@ -192,7 +214,7 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do id (\db -> (("HASKELL_PACKAGE_SANDBOX", fpToString db):)) (pbDatabase pb) - (map fixEnv env) + (filter allowedEnv $ map fixEnv env) , sbHaddockFiles = haddockFiles } @@ -210,6 +232,8 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do | 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 @@ -218,6 +242,12 @@ performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do 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) @@ -232,8 +262,10 @@ data SingleBuild = SingleBuild , sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file } -singleBuild :: PerformBuild -> SingleBuild -> IO () -singleBuild pb@PerformBuild {..} SingleBuild {..} = +singleBuild :: PerformBuild + -> Set PackageName -- ^ registered packages + -> SingleBuild -> IO () +singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = withCounter sbActive $ handle updateErrs $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False)) @@ -245,11 +277,13 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} = let wfd comps = waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo . withTSem sbSem - wfd libComps buildLibrary + withUnpacked <- wfd libComps buildLibrary - wfd testComps runTests + wfd testComps (runTests withUnpacked) - name = display $ piName sbPackageInfo + pname = piName sbPackageInfo + pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo) + name = display pname namever = concat [ name , "-" @@ -290,6 +324,7 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} = withBinaryFile (fpToString fp) WriteMode inner' 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 @@ -298,6 +333,9 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} = 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:) @@ -312,20 +350,39 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} = PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo buildLibrary = wf libOut $ \outH -> do - let run = runChild outH - log' $ "Unpacking " ++ namever - runParent outH "cabal" ["unpack", namever] + let run a b = do when pbVerbose $ log' (unwords (a : b)) + runChild outH a b - log' $ "Configuring " ++ namever - run "cabal" $ "configure" : configArgs + isUnpacked <- newIORef False + let withUnpacked inner = do + unlessM (readIORef isUnpacked) $ do + log' $ "Unpacking " ++ namever + runParent outH "cabal" ["unpack", namever] + writeIORef isUnpacked True + inner - log' $ "Building " ++ namever - run "cabal" ["build"] + isConfiged <- newIORef False + let withConfiged inner = withUnpacked $ do + unlessM (readIORef isConfiged) $ do + log' $ "Configuring " ++ namever + run "cabal" $ "configure" : configArgs + writeIORef isConfiged True + inner - log' $ "Copying/registering " ++ namever - run "cabal" ["copy"] - withMVar sbRegisterMutex $ const $ - run "cabal" ["register"] + 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 @@ -335,7 +392,11 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} = -- dependency's haddocks before this finishes atomically $ putTMVar (piResult sbPackageInfo) True - when (pcHaddocks /= Don'tBuild && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)) $ do + 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 @@ -370,15 +431,21 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} = $ 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 () - runTests = wf testOut $ \outH -> do + return withUnpacked + + runTests withUnpacked = wf testOut $ \outH -> do let run = runChild outH - when (pcTests /= Don'tBuild) $ do + 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 @@ -389,6 +456,7 @@ singleBuild pb@PerformBuild {..} SingleBuild {..} = 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" @@ -421,3 +489,52 @@ copyBuiltInHaddocks docdir = 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/UpdateBuildPlan.hs b/Stackage/UpdateBuildPlan.hs index 617560b5..8c67c5ef 100644 --- a/Stackage/UpdateBuildPlan.hs +++ b/Stackage/UpdateBuildPlan.hs @@ -15,8 +15,9 @@ import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.Prelude -updateBuildPlan :: BuildPlan -> IO BuildPlan -updateBuildPlan = newBuildPlan . updateBuildConstraints +updateBuildPlan :: Map PackageName PackagePlan -> BuildPlan -> IO BuildPlan +updateBuildPlan packagesOrig + = newBuildPlan packagesOrig . updateBuildConstraints updateBuildConstraints :: BuildPlan -> BuildConstraints updateBuildConstraints BuildPlan {..} = @@ -33,6 +34,7 @@ updateBuildConstraints BuildPlan {..} = , 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 diff --git a/Stackage/Upload.hs b/Stackage/Upload.hs index bea1c289..3282bf91 100644 --- a/Stackage/Upload.hs +++ b/Stackage/Upload.hs @@ -11,6 +11,7 @@ module Stackage.Upload , UploadDocs (..) , uploadDocs , uploadHackageDistro + , uploadHackageDistroNamed , UploadDocMap (..) , uploadDocMap , uploadBundleV2 @@ -145,8 +146,28 @@ uploadHackageDistro :: BuildPlan -> ByteString -- ^ Hackage password -> Manager -> IO (Response LByteString) -uploadHackageDistro bp username password = - httpLbs (applyBasicAuth username password req) +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 @@ -164,13 +185,6 @@ uploadHackageDistro bp username password = (toBuilder $ display name) ++ "\"" - req = "http://hackage.haskell.org/distro/Stackage/packages.csv" - { requestHeaders = [("Content-Type", "text/csv")] - , requestBody = RequestBodyLBS csv - , checkStatus = \_ _ _ -> Nothing - , method = "PUT" - } - data UploadDocMap = UploadDocMap { udmServer :: StackageServer , udmAuthToken :: Text diff --git a/app/stackage.hs b/app/stackage.hs index b78dbb9c..1b9583c7 100644 --- a/app/stackage.hs +++ b/app/stackage.hs @@ -1,16 +1,163 @@ +{-# 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 System.Environment (getArgs) +import Stackage.InstallBuild main :: IO () -main = do - args <- getArgs - case args of - [x] | Just y <- lookup x m -> y - _ -> error $ "Expected one argument, one of: " ++ unwords (map fst m) +main = + join $ + execParser $ + info + (helpOption <*> versionOption <*> config) + (header "Stackage" <> + fullDesc) where - m = - [ ("nightly", completeBuild Nightly) - , ("lts-major", completeBuild $ LTS Major) - , ("lts-minor", completeBuild $ LTS Minor) - , ("check", justCheck) - ] + 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 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") + + 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") diff --git a/build-constraints.yaml b/build-constraints.yaml index f23f511c..1b343254 100644 --- a/build-constraints.yaml +++ b/build-constraints.yaml @@ -2,7 +2,7 @@ packages: "Michael Snoyman michael@snoyman.com @snoyberg": - bzlib-conduit - - cabal-install < 1.19 + - cabal-install < 1.19 # GHC 7.10 bumpd to 1.22 - cabal-src - case-insensitive - classy-prelude-yesod @@ -27,7 +27,10 @@ packages: - warp-tls - yackage - yesod + - yesod-auth + - yesod-auth-oauth - yesod-auth-deskcom + - authenticate-oauth - yesod-bin - yesod-eventsource - yesod-fay @@ -42,6 +45,11 @@ packages: - repa-algorithms - repa-devil - JuicyPixels-repa + - cereal-conduit + - binary-conduit + - lzma-conduit + - mutable-containers + - hpc-coveralls "FP Complete michael@fpcomplete.com @snoyberg": - alex @@ -64,7 +72,7 @@ packages: - fixed-list - foreign-store - formatting - - fpco-api + #- fpco-api - gtk2hs-buildtools - happy - histogram-fill @@ -105,18 +113,18 @@ packages: - distributed-process-async - distributed-process-client-server - distributed-process-supervisor - - # https://github.com/fpco/stackage/issues/381 - #- distributed-process-task - #- distributed-process-execution + - distributed-process-task + - distributed-process-execution - kure "Omari Norman ": - barecheck - rainbow - - rainbow-tests - quickpull + - multiarg + - prednote + - cartel "Neil Mitchell": - hlint @@ -144,6 +152,7 @@ packages: "Jasper Van der Jeugt": - blaze-html - blaze-markup + - hakyll - stylish-haskell "Antoine Latter": @@ -175,7 +184,6 @@ packages: - crypto-random-api - hit - language-java - - language-java - libgit - pem - siphash @@ -202,8 +210,11 @@ packages: - scrobble - shell-conduit - sourcemap + - hindent + - descriptive + - wrap # requires old haddock currently - haskell-docs - # TODO: Add hindent and structured-haskell-mode once they've been ported to HSE 1.16. + # TODO: Add structured-haskell-mode once they've been ported to HSE 1.16. # GHC 7.6 # "Alberto G. Corona ": @@ -253,7 +264,7 @@ packages: - monad-products - monad-st - monad-st - - mtl < 2.2 + - mtl < 2.2 # GHC 7.10 bump - nats - numeric-extras - parsers @@ -304,8 +315,9 @@ packages: "Brent Yorgey ": - active - - BlogLiterately - - BlogLiterately-diagrams + # Temporarily disabled due to restrictive lens upper bound + #- BlogLiterately + #- BlogLiterately-diagrams - diagrams - diagrams-builder - diagrams-contrib @@ -325,6 +337,8 @@ packages: - JuicyPixels - FontyFruity - Rasterific + - svg-tree + - rasterific-svg "Patrick Brisbin": - gravatar @@ -365,6 +379,7 @@ packages: - pipes - pipes-parse - pipes-concurrency + - pipes-safe "Chris Allen ": - bloodhound @@ -378,6 +393,10 @@ packages: - fay-uri - snaplet-fay + "Sebastiaan Visser ": + - clay + - fclabels + "Rodrigo Setti ": - messagepack - messagepack-rpc @@ -399,9 +418,11 @@ packages: - hPDB - hPDB-examples - # https://github.com/fpco/stackage/pull/382#issuecomment-68182467 - # - wordpass - # - json-autotype + - wordpass + - json-autotype + + "Dominic Steinitz ": + - yarr "Roman Cheplyaka ": - action-permutations @@ -431,6 +452,7 @@ packages: "George Giorgidze ": - HCodecs - YampaSynth + - set-monad "Phil Hargett ": - courier @@ -444,6 +466,8 @@ packages: - circle-packing - arbtt - ghc-heap-view + - tttool + - gipeda "Aditya Bhargava ": @@ -509,7 +532,10 @@ packages: - io-manager "Dimitri Sabadie ": - ghc-syb-utils @@ -543,6 +569,7 @@ packages: "Emanuel Borsobom ": - BoundedChan + - broadcast-chan - bytestring-lexing - bytestring-trie - data-accessor @@ -553,6 +580,7 @@ packages: - haddock-api - here - hlibgit2 + - gitlib-libgit2 - hostname-validate - interpolatedstring-perl6 - iproute @@ -561,6 +589,7 @@ packages: - multimap - parallel-io - text-binary + - wl-pprint-text "Michael Sloan ": - aeson-pretty @@ -618,42 +652,137 @@ packages: - shake-language-c "Marcin Mrotek ": + - diagrams-hsqml - type-list - + - vinyl-utils + + "Marcin Mrotek ": + - type-list + "David Turner ": - alarmclock - bank-holidays-england + "Haskell Servant jkarni@gmail.com @jkarni": + - servant + - servant-client + - servant-docs + - servant-jquery + - servant-server + + "Alexandr Ruchkin voidex@live.com @mvoidex": + - hdocs + - hsdev + + "Aleksey Kliger aleksey@lambdageek.org @lambdageek": + - unbound-generics + + "Alois Cochard alois.cochard@gmail.com @aloiscochard": + - codex + - machines-directory + - machines-io + - machines-process + # on behalf of Bryan O'Sullivan @bos + - wreq + + "Andraz Bajt andraz@bajt.me @edofic": + - effect-handlers + - koofr-client + - snowflake + + "Leza M. Lutonda lemol-c@hotmail.com @lemol": + - HaskellNet + + "Jens Petersen juhpetersen@gmail.com @juhp": + - cabal-rpm + + "Renzo Carbonara renzocarbonara@gmail.com @k0001": + - network-simple + - pipes-aeson + - pipes-attoparsec + - pipes-binary + - pipes-network + + "Tomas Carnecky": + - rethinkdb-client-driver + + "Alexandr Kurilin alex@kurilin.net @alex_kurilin": + - bcrypt + + "Jeffrey Rosenbluth jeffrey.rosenbluth@gmail.com": + - palette + - diagrams-canvas + - diagrams-rasterific + - lucid-svg + + "Gabríel Arthúr Pétursson gabriel@system.is": + - sdl2 + + "Leon Mergen leon@solatis.com @solatis": + - network-attoparsec + - network-anonymous-i2p + + "Timothy Jones git@zmthy.io @zmthy": + - cabal-test-quickcheck + - http-media + + "Greg V greg@unrelenting.technology @myfreeweb": + - gitson + - pcre-heavy + + "Francesco Mazzoli f@mazzo.li @bitonic": + - language-c-quote + + "Sönke Hahn soenkehahn@gmail.com @soenkehahn": + - string-conversions + + "Oleg Grenrus oleg.grenrus@iki.fi @phadej": + - waitra + "Stackage upper bounds": # Force a specific version that's compatible with transformers 0.3 - - transformers-compat == 0.3.3.3 + - transformers-compat == 0.4.0.3 - # https://github.com/fpco/stackage/issues/291 - - random < 1.0.1.3 + # https://github.com/fpco/stackage/issues/390 + # NOTE: When this issue is resolved, remove the expected test failure + # for language-ecmascript as well. + - language-ecmascript < 0.17 - # https://github.com/fpco/stackage/issues/318 - - HaXml < 1.25 + # https://github.com/fpco/stackage/issues/407 + - HStringTemplate < 0.8 - # https://github.com/fpco/stackage/issues/319 - - polyparse < 1.10 + # https://github.com/fpco/stackage/issues/410 + - elm-package < 0.4 - # https://github.com/fpco/stackage/issues/370 - - monad-control < 1 - - hasql < 0.5 - - list-t < 0.4 + # https://github.com/fpco/stackage/issues/415 + - hackage-db < 1.12 -# Global flags are applied to all packages -global-flags: - blaze_html_0_5: true - small_base: true - https: true - splitbase: true - old-locale: true - new-base: true - bytestring-in-base: false - test-hlint: false - network-uri: true + # https://github.com/fpco/stackage/issues/424 + - control-monad-free < 0.6 + + # https://github.com/fpco/stackage/issues/426 + - utf8-string < 1 + + # https://github.com/fpco/stackage/issues/440 + - th-orphans < 0.9 + - file-location < 0.4.7 + + # https://github.com/fpco/stackage/issues/442 + - blaze-builder < 0.4 + - blaze-markup < 0.7 + - blaze-html < 0.8 + + # https://github.com/fpco/stackage/issues/443 + - exceptions < 0.7 + - rest-client < 0.5 + - rest-types < 1.13 + - rest-core < 0.35 + - rest-gen < 0.17 + - rest-wai < 0.1.0.7 + + # https://github.com/fpco/stackage/issues/467 + - lens < 4.8 # Package flags are applied to individual packages, and override the values of # global-flags @@ -672,6 +801,44 @@ package-flags: simplelocalnet: true p2p: true + # GHC 7.10: Remove this + # Note that the flag is lower-cased, because that's what Cabal does + # Perhaps the codebase should automatically lower case flag names? + storable-complex: + instanceinbase: false + + logfloat: + splitbase: true + + curl: + new-base: true + + # GHC 7.10 remove + aeson: + old-locale: true + tttool: + old-locale: true + + hxt: + network-uri: true + hxt-http: + network-uri: true + hxt-relaxng: + network-uri: true + + pandoc: + https: true + + text: + integer-simple: false + + tar: + old-time: false + + mtl-compat: + two-point-one: true + two-point-two: false + # By skipping a test suite, we do not pull in the build dependencies skipped-tests: - ReadArgs # old version of hspec @@ -718,17 +885,15 @@ skipped-tests: # https://github.com/fpco/stackage/pull/380#issuecomment-68060871 - Rasterific + # https://github.com/Soostone/retry/issues/18 + - retry + # Tests which we should build and run, but which are expected to fail. We # should not fail a build based on a test failure for one of these packages. expected-test-failures: # Requires an old version of WAI and Warp for tests - HTTP - # text and setenv have recursive dependencies in their tests, which - # cabal can't (yet) handle - - text - - setenv - # https://github.com/bos/statistics/issues/42 - statistics @@ -852,6 +1017,61 @@ expected-test-failures: - crypto-numbers - distributed-process-task + # https://github.com/vincenthz/hs-crypto-pubkey/issues/17 + - crypto-pubkey + + # https://github.com/jswebtools/language-ecmascript/issues/60 + - language-ecmascript + + # https://github.com/kazu-yamamoto/unix-time/issues/29 + - unix-time + + # Tests can fail when the build plan fails, which happens arbitrarily. + - stackage + + # https://github.com/TomMD/DRBG/issues/7 + - DRBG + + # https://github.com/bos/wreq/issues/53 + - wreq + + # Requires local database running + - rethinkdb-client-driver + + # https://github.com/haskell-distributed/distributed-process-execution/issues/2 + - distributed-process-execution + + # Seems to depend on mtl being installed in user package database, which + # isn't always the case (e.g., build server) + - happy + + # https://github.com/jberryman/directory-tree/issues/4 + - directory-tree + + # https://github.com/zmthy/http-media/issues/11 + - http-media + + # https://github.com/ekmett/semigroupoids/issues/18 + - semigroupoids + + # https://github.com/ndmitchell/hoogle/issues/101 + - hoogle + + # https://github.com/myfreeweb/gitson/issues/1 + - gitson + + # https://github.com/jcristovao/enclosed-exceptions/issues/6 + - enclosed-exceptions + + # Expects a running PostgreSQL server + - users-postgresql-simple + + # Problems with linking with system libraries on Ubuntu 12.04 + - nettle + + # Requires locally running services + - network-anonymous-i2p + # Haddocks which are expected to fail. Same concept as expected test failures. expected-haddock-failures: # https://github.com/acw/bytestring-progress/issues/4 @@ -860,6 +1080,12 @@ expected-haddock-failures: # https://github.com/ekmett/gl/issues/4 - gl + # https://github.com/leventov/yarr/issues/5 + - yarr + + # https://github.com/wereHamster/rethinkdb-client-driver/issues/1 + - rethinkdb-client-driver + # Benchmarks which should not be built. Note that Stackage does *not* generally # build benchmarks. The difference here will be whether dependencies for these # benchmarks are included or not. @@ -886,6 +1112,10 @@ skipped-benchmarks: # sometimes falls out-of-sync on hasql-postgres - hasql +skipped-profiling: + # https://github.com/nomeata/ghc-heap-view/commit/8d198eb8fbbad2ce0c4527c781659f35b8909c04#diff-8288955e209cfbead5b318a8598be9c0R10 + - ghc-heap-view + # Mapping from Github account holding a package to the Github users who should # be pinged on failure. If no value is specified here, then the owning account # will be pinged. @@ -908,3 +1138,5 @@ github-users: - mightybyte haskell-ro: - mihaimaruseac + elm-lang: + - JoeyEremondi diff --git a/cabal.config b/cabal.config index 25f3661e..cc656768 100644 --- a/cabal.config +++ b/cabal.config @@ -647,7 +647,7 @@ constraints: abstract-deque ==0.3, semigroups ==0.16.0.1, sendfile ==0.7.9, seqloc ==0.6, - setenv ==0.1.1.1, + setenv ==0.1.1.2, SHA ==1.6.4.1, shake ==0.14.2, shake-language-c ==0.6.3, diff --git a/debian-bootstrap.sh b/debian-bootstrap.sh index 13d45155..827e8460 100755 --- a/debian-bootstrap.sh +++ b/debian-bootstrap.sh @@ -10,13 +10,17 @@ # instructions, see: # http://www.stackage.org/install -sudo add-apt-repository -y ppa:chris-lea/zeromq -sudo add-apt-repository -y ppa:floe/libtisch -sudo apt-get update -sudo apt-get install -y \ +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 \ @@ -33,11 +37,11 @@ sudo apt-get install -y \ llvm \ libbz2-dev \ libjudy-dev \ + libsqlite3-dev \ libmysqlclient-dev \ libpq-dev \ libicu-dev \ libssl-dev \ - nettle-dev \ libgsl0-dev \ libblas-dev \ liblapack-dev \ @@ -46,4 +50,22 @@ sudo apt-get install -y \ 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 index d9e2a06d..df327327 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -1,5 +1,5 @@ name: stackage -version: 0.4.0 +version: 0.5.2 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 @@ -12,6 +12,7 @@ build-type: Simple cabal-version: >=1.10 extra-source-files: README.md ChangeLog.md + test/test-build-constraints.yaml library default-language: Haskell2010 @@ -22,7 +23,9 @@ library Stackage.BuildPlan Stackage.CheckBuildPlan Stackage.UpdateBuildPlan + Stackage.GhcPkg Stackage.GithubPings + Stackage.InstallBuild Stackage.PackageDescription Stackage.ServerBundle Stackage.Upload @@ -62,6 +65,7 @@ library , streaming-commons >= 0.1.7.1 , semigroups , xml-conduit + , conduit executable stackage default-language: Haskell2010 @@ -69,6 +73,8 @@ executable stackage main-is: stackage.hs build-depends: base , stackage + , optparse-applicative >= 0.11 + , system-filepath ghc-options: -rtsopts -threaded -with-rtsopts=-N test-suite spec diff --git a/test/Stackage/BuildPlanSpec.hs b/test/Stackage/BuildPlanSpec.hs index aa33c8dd..b87c74d2 100644 --- a/test/Stackage/BuildPlanSpec.hs +++ b/test/Stackage/BuildPlanSpec.hs @@ -1,21 +1,66 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-} module Stackage.BuildPlanSpec (spec) where -import Stackage.BuildPlan -import Stackage.Prelude -import Stackage.BuildConstraints -import Stackage.UpdateBuildPlan -import Test.Hspec -import qualified Data.Yaml as Y -import Distribution.Version (anyVersion) import qualified Data.Map as Map -import Network.HTTP.Client (withManager) -import Network.HTTP.Client.TLS (tlsManagerSettings) +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 = it "works" $ withManager tlsManagerSettings $ \man -> do - bc <- defaultBuildConstraints man - bp <- newBuildPlan bc +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 @@ -25,14 +70,74 @@ spec = it "works" $ withManager tlsManagerSettings $ \man -> do forM_ allPackages $ \name -> (name, lookup name (bpPackages bp')) `shouldBe` (name, lookup name (bpPackages bp)) - bpGithubUsers bp' `shouldBe` bpGithubUsers bp + when (bp' /= bp) $ error "bp' /= bp" - bp2 <- updateBuildPlan bp + 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/test-build-constraints.yaml b/test/test-build-constraints.yaml new file mode 100644 index 00000000..de831eaf --- /dev/null +++ b/test/test-build-constraints.yaml @@ -0,0 +1,20 @@ +packages: + "Test": + - foo + - bar + +global-flags: [] + +skipped-tests: [] +expected-test-failures: [] +expected-haddock-failures: [] +skipped-benchmarks: [] +skipped-profiling: [] + +github-users: + bar: + - demo + +package-flags: + foo: + demo: true