diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ +## 0.13.2 + +* --no-rebuild-cabal +* Fix allow-newer by simply stripping all version bounds in .cabal files +* Fix build failure [#13](https://github.com/fpco/stackage-curator/issues/13) + ## 0.13.1 * Let test suite pass when no package index available [stackage#1165](https://github.com/fpco/stackage/issues/1165) diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs --- a/Stackage/BuildPlan.hs +++ b/Stackage/BuildPlan.hs @@ -134,8 +134,16 @@ name = spdName spd ppVersion = spdVersion spd ppGithubPings = applyGithubMapping bc $ spdGithubPings spd - ppConstraints = bcPackageConstraints bc name + ppConstraints = onlyRelevantFlags $ bcPackageConstraints bc name ppUsers = mempty -- must be filled in later + + -- Only include flags that are actually provided by the package. For more + -- information, see: https://github.com/fpco/stackage-curator/issues/11 + onlyRelevantFlags :: PackageConstraints -> PackageConstraints + onlyRelevantFlags pc = pc + { pcFlagOverrides = pcFlagOverrides pc `intersection` + spdPackageFlags spd + } ccPackageName = name ccOS = siOS diff --git a/Stackage/CheckBuildPlan.hs b/Stackage/CheckBuildPlan.hs --- a/Stackage/CheckBuildPlan.hs +++ b/Stackage/CheckBuildPlan.hs @@ -29,38 +29,44 @@ allPackages = map (,mempty) (siCorePackages bpSystemInfo) ++ map (ppVersion &&& M.keys . M.filter libAndExe . sdPackages . ppDesc) bpPackages errs@(BadBuildPlan errs') = - execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages + execWriter $ mapM_ (checkDeps getMaint 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 + getMaint :: PackageName -> Maybe Maintainer + getMaint pn = do + pp <- lookup pn bpPackages + pcMaintainer $ ppConstraints pp + -- | 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]) +checkDeps :: (PackageName -> Maybe Maintainer) + -> Map PackageName (Version,[PackageName]) -> (PackageName, PackagePlan) -> Writer BadBuildPlan () -checkDeps allPackages (user, pb) = +checkDeps getMaint 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 + Nothing -> tell $ BadBuildPlan $ singletonMap (dep, getMaint dep, Nothing) errMap Just (version,deps) | version `withinRange` range -> occursCheck allPackages (\d v -> tell $ BadBuildPlan $ singletonMap - (d,v) + (d, getMaint dep, v) errMap) dep deps [] | otherwise -> tell $ BadBuildPlan $ singletonMap - (dep, Just version) + (dep, getMaint dep, Just version) errMap where errMap = singletonMap pu range @@ -124,25 +130,40 @@ : map (cons '@') (setToList puGithubPings) newtype BadBuildPlan = - BadBuildPlan (Map (PackageName, Maybe Version) (Map PkgUser VersionRange)) + BadBuildPlan (Map (PackageName, Maybe Maintainer, 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 + go ((dep, mmaint, mdepVer), users) = unlines $ "" - : showDepVer dep mdepVer + : showDepVer dep mmaint 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 + showDepVer :: PackageName + -> Maybe Maintainer + -> Maybe Version + -> Text + showDepVer dep mmaint Nothing = T.concat [ display dep + , displayMaint mmaint + , " (not present) depended on by:" + ] + showDepVer dep mmaint (Just version) = concat + [ display dep , "-" , display version + , displayMaint mmaint , " is out of bounds for:" + ] + + displayMaint Nothing = "" + displayMaint (Just (Maintainer t)) = T.concat + [ " (" + , t + , ")" ] showUser :: (PkgUser, VersionRange) -> Text diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -33,7 +33,7 @@ import Stackage.BuildPlan import Stackage.CheckBuildPlan import Stackage.PerformBuild -import Stackage.Prelude +import Stackage.Prelude hiding (threadDelay, getNumCapabilities) import Stackage.ServerBundle import Stackage.UpdateBuildPlan import Stackage.Upload @@ -409,10 +409,12 @@ -> Bool -- ^ enable executable dynamic? -> Bool -- ^ verbose? -> Bool -- ^ allow-newer? + -> Bool -- ^ no rebuild cabal? -> IO () makeBundle planFile docmapFile bundleFile target mjobs skipTests skipHaddocks skipHoogle enableLibraryProfiling enableExecutableDynamic verbose allowNewer + noRebuildCabal = do plan <- decodeFileEither planFile >>= either throwM return jobs <- maybe getNumCapabilities return mjobs @@ -433,6 +435,7 @@ , pbVerbose = verbose , pbAllowNewer = allowNewer , pbBuildHoogle = not skipHoogle + , pbNoRebuildCabal = noRebuildCabal } putStrLn "Performing build" diff --git a/Stackage/Curator/UploadDocs.hs b/Stackage/Curator/UploadDocs.hs --- a/Stackage/Curator/UploadDocs.hs +++ b/Stackage/Curator/UploadDocs.hs @@ -11,7 +11,7 @@ ( uploadDocs , upload ) where -import ClassyPrelude.Conduit +import ClassyPrelude.Conduit hiding (threadDelay) import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import Control.Monad.Trans.Resource (liftResourceT) diff --git a/Stackage/InstallBuild.hs b/Stackage/InstallBuild.hs --- a/Stackage/InstallBuild.hs +++ b/Stackage/InstallBuild.hs @@ -35,6 +35,7 @@ , ifVerbose :: !Bool , ifSkipCheck :: !Bool , ifBuildHoogle :: !Bool + , ifNoRebuildCabal :: !Bool } deriving (Show) -- | Source for build plan. @@ -58,6 +59,7 @@ , pbVerbose = ifVerbose , pbAllowNewer = ifSkipCheck , pbBuildHoogle = ifBuildHoogle + , pbNoRebuildCabal = ifNoRebuildCabal } -- | Install stackage from an existing build plan. diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -18,10 +18,14 @@ import Control.Concurrent.STM.TSem import Control.Monad.Writer.Strict (execWriter, tell) import qualified Data.ByteString as S +import Data.Generics (mkT, everywhere) import qualified Data.Map as Map import Data.NonNull (fromNullable) import Distribution.PackageDescription (buildType, packageDescription, BuildType (Simple), condTestSuites) +import Distribution.Package (Dependency (..)) +import Distribution.PackageDescription.PrettyPrint (writeGenericPackageDescription) +import Distribution.Version (anyVersion) import Filesystem (canonicalizePath, createTree, getWorkingDirectory, removeTree, rename, removeFile) @@ -78,11 +82,14 @@ , pbEnableExecDyn :: Bool , pbVerbose :: Bool , pbAllowNewer :: Bool - -- ^ Pass --allow-newer to cabal configure + -- ^ Strip out version bounds in .cabal files , pbBuildHoogle :: Bool -- ^ Should we build Hoogle database? -- -- May be disabled due to: https://ghc.haskell.org/trac/ghc/ticket/9921 + , pbNoRebuildCabal :: !Bool + -- ^ Ignore new Cabal version from the plan and use whatever's in the + -- database. Useful for testing pre-release GHCs } data PackageInfo = PackageInfo @@ -285,7 +292,11 @@ where libComps = setFromList [CompLibrary, CompExecutable] testComps = insertSet CompTestSuite libComps - inner = do + + inner + | pname == PackageName "Cabal" && pbNoRebuildCabal = + atomically $ putTMVar (piResult sbPackageInfo) True + | otherwise = do let wfd comps = waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo . withTSem sbSem @@ -324,8 +335,18 @@ , "\n" ] hFlush outH - withCheckedProcess (cp outH) $ \ClosedStream UseProvidedHandle UseProvidedHandle -> - (return () :: IO ()) + + -- instead of using withCheckedProcess, we go lower-level so that we + -- can kill the process in the case of an async exception (via the + -- timeout call below) + let cp' = cp outH + (ClosedStream, UseProvidedHandle, UseProvidedHandle, sph) + <- streamingProcess cp' + ec <- waitForStreamingProcess sph `onException` do + -- Call the process + let ph = streamingProcessHandleRaw sph + terminateProcess ph + unless (ec == ExitSuccess) $ throwIO $ ProcessExitedUnsuccessfully cp' ec where cp outH = (proc (unpack cmd) (map unpack args)) { cwd = Just wdir @@ -377,7 +398,6 @@ Just db -> ("-package-db=" ++ pack db) : rest) configArgs = ($ []) $ execWriter $ do - when pbAllowNewer $ tell' "--allow-newer" tell' "--package-db=clear" tell' "--package-db=global" forM_ (pbDatabase pb) $ \db -> tell' $ "--package-db=" ++ pack db @@ -423,7 +443,7 @@ log' $ "Unpacking " ++ namever runParent getOutH "stack" ["unpack", namever] - gpd <- createSetupHs childDir name + gpd <- createSetupHs childDir name pbAllowNewer writeIORef gpdRef $ Just gpd return gpd @@ -744,10 +764,18 @@ -- Also deletes any Setup.lhs if necessary createSetupHs :: FilePath -> Text -- ^ package name + -> Bool -- ^ allow newer? -> IO GenericPackageDescription -createSetupHs dir name = do +createSetupHs dir name allowNewer = do bs <- readFile cabalFP - gpd <- gpdFromLBS cabalFP (fromStrict bs) + gpd' <- gpdFromLBS cabalFP (fromStrict bs) + gpd <- + if allowNewer + then do + let gpd = stripVersionBounds gpd' + writeGenericPackageDescription cabalFP gpd + return gpd + else return gpd' let simple = buildType (packageDescription gpd) == Just Simple when simple $ do _ <- tryIO $ removeFile $ fromString setuplhs @@ -757,3 +785,7 @@ cabalFP = dir unpack name <.> "cabal" setuphs = dir "Setup.hs" setuplhs = dir "Setup.lhs" + +-- | Strip all version bounds from a GenericPackageDescription +stripVersionBounds :: GenericPackageDescription -> GenericPackageDescription +stripVersionBounds = everywhere $ mkT $ \(Dependency name _) -> Dependency name anyVersion diff --git a/app/stackage.hs b/app/stackage.hs --- a/app/stackage.hs +++ b/app/stackage.hs @@ -86,6 +86,7 @@ <*> enableExecutableDynamic <*> verbose <*> allowNewer + <*> noRebuildCabal installFlags :: Parser InstallFlags @@ -148,7 +149,13 @@ not (switch (long "skip-hoogle" <> - help "Skip generating Hoogle input files")) + help "Skip generating Hoogle input files")) <*> + noRebuildCabal + + noRebuildCabal = + switch + (long "no-rebuild-cabal" <> + help "Ignore new Cabal version from the plan and use whatever's in the database. Useful for testing pre-release GHCs") jobs = (fmap Just (option diff --git a/stackage-curator.cabal b/stackage-curator.cabal --- a/stackage-curator.cabal +++ b/stackage-curator.cabal @@ -1,5 +1,5 @@ name: stackage-curator -version: 0.13.1 +version: 0.13.2 synopsis: Tools for curating Stackage bundles description: Please see for a description and documentation. homepage: https://github.com/fpco/stackage @@ -91,6 +91,7 @@ , lucid , binary , binary-tagged + , syb executable stackage-curator default-language: Haskell2010