diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,14 @@ +## 0.16.0.0 + +* Use Cabal.Simple.BuildToolDepends.getAllToolDependencies to compute the tools field of SimpleDesc [#52](https://github.com/fpco/stackage-curator/issues/52) +* Do not build tests/benches if there are no test suites or benchmarks +* `non-parallel-build` +* Cabal 2.2 + +## 0.15.2.0 + +* Add a check for mistyped or otherwise unknown package names [#47](https://github.com/fpco/stackage-curator/issues/47) + ## 0.15.1.0 * `skipped-haddocks` diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs --- a/Stackage/BuildConstraints.hs +++ b/Stackage/BuildConstraints.hs @@ -21,6 +21,7 @@ import Control.Monad.Writer.Strict (execWriter, tell) import Data.Aeson import Data.Aeson.Internal ((), JSONPathElement (Key)) +import Data.Char (isLower) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Yaml (decodeEither', decodeFileEither) @@ -140,11 +141,15 @@ -- ^ Packages which should be hidden after registering , cfNoRevisions :: !(Set PackageName) -- ^ Packages where we should ignore any Hackage revisions + , cfNonParallelBuild :: !(Set PackageName) + -- ^ Don't build these in parallel } instance FromJSON ConstraintFile where parseJSON = withObject "ConstraintFile" $ \o -> do - cfPackageFlags <- (goPackageMap . fmap goFlagMap) <$> o .: "package-flags" + cfPackageFlags <- (o .: "package-flags") + >>= fmap goPackageMap + . mapM (fmap Map.fromList . mapM goFlagPair . Map.toList) cfConfigureArgs <- goPackageMap <$> o .:? "configure-args" .!= mempty cfSkippedTests <- getPackages o "skipped-tests" cfSkippedBuilds <- getPackages o "skipped-builds" <|> return mempty @@ -167,9 +172,14 @@ Key "tell-me-when-its-released" cfHide <- Set.map mkPackageName <$> o .:? "hide" .!= mempty cfNoRevisions <- Set.map mkPackageName <$> o .:? "no-revisions" .!= mempty + cfNonParallelBuild <- Set.map mkPackageName <$> o .:? "non-parallel-build" .!= mempty return ConstraintFile {..} where - goFlagMap = Map.mapKeysWith const mkFlagName + goFlagPair :: Monad m => (Text, v) -> m (FlagName, v) + goFlagPair (t, v) + | t == toLower t = return (mkFlagName $ unpack t, v) + | otherwise = fail $ "Non-lowercase flag name, " ++ unpack t ++ ". See https://github.com/fpco/stackage-curator/issues/57" + goPackageMap = Map.mapKeysWith const mkPackageName getPackages o name = (setFromList . map mkPackageName) <$> o .: name @@ -242,6 +252,7 @@ pcConfigureArgs = fromMaybe mempty $ lookup name cfConfigureArgs pcSkipBuild = name `member` cfSkippedBuilds pcHide = name `member` cfHide + pcNonParallelBuild = name `member` cfNonParallelBuild bcGithubUsers = cfGithubUsers bcBuildToolOverrides = cfBuildToolOverrides diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs --- a/Stackage/BuildPlan.hs +++ b/Stackage/BuildPlan.hs @@ -19,6 +19,7 @@ ) where import Control.Monad.State.Strict (execState, get, put) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set import qualified Distribution.Compiler @@ -36,6 +37,17 @@ -> BuildConstraints -> m BuildPlan newBuildPlan eallCabalHashesCommit packagesOrig packagesLatest bc@BuildConstraints {..} = liftIO $ do + unless (Map.null packagesLatest) $ do + let unknownPackages = bcPackages `Set.difference` Map.keysSet packagesLatest + forM_ (NE.nonEmpty $ setToList unknownPackages) $ \pkgNames -> do + putStrLn "Couldn't find the following package names in the package index:" + forM_ pkgNames $ \p -> do + let mmaintainer = unMaintainer <$> pcMaintainer (bcPackageConstraints p) + maintainerT = fromMaybe "" ((++ ")") . (" (" ++) <$> mmaintainer) + putStrLn ("- " ++ display p ++ maintainerT) + putStrLn "Please check them for typos." + error "Exiting due to unknown packages" + let newReleased = mapMaybe checkReleased $ mapToList bcTellMeWhenItsReleased checkReleased (name, expectedVersion) = case lookup name packagesLatest of diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} diff --git a/Stackage/PackageIndex.hs b/Stackage/PackageIndex.hs --- a/Stackage/PackageIndex.hs +++ b/Stackage/PackageIndex.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} @@ -35,9 +34,9 @@ import Distribution.Version (VersionRange (..)) import Distribution.Package (Dependency (..)) import Distribution.PackageDescription -import Distribution.PackageDescription.Parse (ParseResult (..), - parsePackageDescription) -import Distribution.ParseUtils (PError) +import Distribution.PackageDescription.Parsec(parseGenericPackageDescription, runParseResult) +import Distribution.Parsec.Common (PError) +import Distribution.Simple.BuildToolDepends (getAllToolDependencies) import Distribution.System (Arch, OS) import Stackage.Prelude import Stackage.GithubPings @@ -109,10 +108,6 @@ } deriving Generic -#if !MIN_VERSION_base(4, 9, 0) -deriving instance Generic Version -#endif - instance Store SimplifiedPackageDescription instance Store a => Store (CondTree ConfVar [Dependency] a) instance Store a => Store (CondBranch ConfVar [Dependency] a) @@ -191,10 +186,11 @@ simpleTest = helper noModules testBuildInfo simpleBench = helper noModules benchmarkBuildInfo + helper :: (a -> Set Text) -> (a -> BuildInfo) -> a -> SimplifiedComponentInfo helper getModules' getBI x = SimplifiedComponentInfo { sciBuildTools = map (\(ExeDependency _ name' range) -> (ExeName $ pack $ unUnqualComponentName name', range)) - (buildToolDepends $ getBI x) + (getAllToolDependencies (packageDescription gpd) (getBI x)) , sciModules = getModules' x } @@ -239,12 +235,9 @@ -> LByteString -> m GenericPackageDescription gpdFromLBS fp lbs = - case parsePackageDescription $ unpack $ dropBOM $ decodeUtf8 lbs of - ParseFailed e -> throwM $ CabalParseException fp e - ParseOk _warnings gpd -> return gpd - where - -- https://github.com/haskell/hackage-server/issues/351 - dropBOM t = fromMaybe t $ stripPrefix "\xFEFF" t + case snd $ runParseResult $ parseGenericPackageDescription $ toStrict lbs of + Left e -> throwM $ CabalParseException fp e + Right gpd -> return gpd -- | Stream all of the cabal files from the 00-index tar file. sourcePackageIndex :: (MonadThrow m, MonadResource m, MonadActive m, MonadBaseControl IO m) @@ -287,7 +280,7 @@ deriving (Show, Typeable) instance Exception InvalidCabalPath -data CabalParseException = CabalParseException FilePath PError +data CabalParseException = CabalParseException FilePath (Maybe Version, [PError]) | MismatchedNameVersion FilePath PackageName PackageName Version Version deriving (Show, Typeable) instance Exception CabalParseException diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -16,15 +16,14 @@ , sdistFilePath ) where -import Control.Concurrent.Async (async) -import Control.Concurrent.STM.TSem +import Control.Concurrent.Async (forConcurrently_) 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) + condTestSuites, condBenchmarks) import Distribution.Package (Dependency (..)) import Distribution.PackageDescription.PrettyPrint (writeGenericPackageDescription) import Distribution.Types.UnqualComponentName @@ -155,9 +154,25 @@ (atomically $ modifyTVar counter (+ 1)) (atomically $ modifyTVar counter (subtract 1)) -withTSem :: TSem -> IO a -> IO a -withTSem sem = bracket_ (atomically $ waitTSem sem) (atomically $ signalTSem sem) +data TSem = TSem !(TVar Int) !Int +newTSemIO :: Int -> IO TSem +newTSemIO x = flip TSem x <$> newTVarIO x + +withTSem :: Bool -- ^ take all resources? + -> TSem + -> IO a + -> IO a +withTSem useAll (TSem var total) inner = bracket + (atomically $ do + avail <- readTVar var + let needed = if useAll then total else 1 + checkSTM $ avail >= needed + writeTVar var $! avail - needed + return needed) + (\needed -> atomically $ modifyTVar var (+ needed)) + (const inner) + -- | Returns @Nothing@ if installing to a global database pbDatabase :: PerformBuild -> Maybe FilePath pbDatabase pb @@ -197,7 +212,7 @@ pbLog $ encodeUtf8 "Copying built-in Haddocks\n" copyBuiltInHaddocks (pbDocDir pb) - sem <- atomically $ newTSem pbJobs + sem <- newTSemIO pbJobs active <- newTVarIO (0 :: Int) let toolMap = makeToolMap (bpBuildToolOverrides pbPlan) (bpPackages pbPlan) @@ -227,7 +242,7 @@ haddockFiles <- getHaddockFiles pb >>= newTVarIO haddockDeps <- newTVarIO mempty - forM_ packageMap $ \pi -> void $ Control.Concurrent.Async.async $ singleBuild pb registeredPackages + forConcurrently_ packageMap $ \pi -> singleBuild pb registeredPackages SingleBuild { sbSem = sem , sbErrsVar = errsVar @@ -314,7 +329,7 @@ | otherwise = do let wfd comps = waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo - . withTSem sbSem + . withTSem pcNonParallelBuild sbSem withUnpacked <- wfd libComps buildLibrary wfd testComps (runTests withUnpacked) @@ -333,8 +348,8 @@ [ namever , fromMaybe (assert False "") $ do cfi <- ppCabalFileInfo $ piPlan sbPackageInfo - hash <- lookup "GitSHA1" $ cfiHashes cfi - Just $ "@gitsha1:" ++ hash + hash <- lookup "SHA256" $ cfiHashes cfi + Just $ "@sha256:" ++ hash ] quote :: Text -> Text @@ -448,7 +463,7 @@ tell' $ "--docdir=" ++ pack (pbDocDir pb unpack namever) tell' $ "--htmldir=" ++ pack (pbDocDir pb unpack namever) tell' $ "--haddockdir=" ++ pack (pbDocDir pb unpack namever) - tell' $ "--flags=" ++ flags + when (not $ null flags) $ tell' $ "--flags=" ++ flags when (pbEnableLibProfiling && pcEnableLibProfile) $ tell' "--enable-library-profiling" when pbEnableExecDyn $ tell' "--enable-executable-dynamic" @@ -471,7 +486,7 @@ buildLibrary = wf libOut $ \getOutH -> do gpdRef <- newIORef Nothing - let withUnpacked inner' = do + let withUnpacked reason inner' = do mgpd <- readIORef gpdRef (gpd, childDir) <- case mgpd of @@ -486,7 +501,7 @@ ] return $ sbBuildDir "cabal" "Cabal" else do - log' $ "Unpacking " ++ nameverrevhash + log' $ "Unpacking " ++ nameverrevhash ++ " (reason: " ++ reason ++ ")" case ppSourceUrl $ piPlan sbPackageInfo of Nothing -> runParent getOutH "stack" ["unpack", nameverrevhash] Just url -> unpackFromURL sbBuildDir url @@ -499,7 +514,7 @@ inner' gpd childDir isConfiged <- newIORef False - let withConfiged inner' = withUnpacked $ \_gpd childDir -> do + let withConfiged reason inner' = withUnpacked ("withConfiged: " ++ reason) $ \_gpd childDir -> do let run a b = do when pbVerbose $ log' (unwords (a : b)) runIn childDir getOutH a b cabal = setup run @@ -523,7 +538,7 @@ ] return True | otherwise -> return False - when toBuild $ withConfiged $ \childDir cabal -> do + when toBuild $ withConfiged "toBuild" $ \childDir cabal -> do deletePreviousResults pb pident log' $ "Building " ++ namever @@ -552,7 +567,7 @@ && checkPrevResult prevHaddockResult pcHaddocks && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo) && not pcSkipBuild - when needHaddock $ withConfiged $ \childDir cabal -> do + when needHaddock $ withConfiged "needHaddock" $ \childDir cabal -> do log' $ "Haddocks " ++ namever hfs <- readTVarIO sbHaddockFiles haddockDeps <- atomically $ getHaddockDeps pbPlan sbHaddockDeps pname @@ -614,72 +629,87 @@ let needTest = pbEnableTests && checkPrevResult prevTestResult pcTests && not pcSkipBuild - when needTest $ withUnpacked $ \gpd childDir -> do - let run = runIn childDir getOutH - cabal = setup run + hasTests = not . null . condTestSuites + when needTest $ withUnpacked "needTest" $ \gpd childDir -> do + -- If there are tests, run them. If not, then return `Right + -- ()`. This was, we'll still save a successful test result + -- and avoid re-unpacking next time around. + eres <- if hasTests gpd + then do + let run = runIn childDir getOutH + cabal = setup run - log' $ "Test configure " ++ namever - cabal $ "configure" : "--enable-tests" : configArgs + log' $ "Test configure " ++ namever + cabal $ "configure" : "--enable-tests" : configArgs - eres <- tryAny $ do - log' $ "Test build " ++ namever - cabal ["build"] + tryAny $ do + log' $ "Test build " ++ namever + cabal ["build"] - let tests = map (unUnqualComponentName . fst) $ condTestSuites gpd - forM_ tests $ \test -> do - log' $ concat - [ "Test run " - , namever - , " (" - , pack test - , ")" - ] - let exe = "dist/build" test test + let tests = map (unUnqualComponentName . fst) $ condTestSuites gpd + forM_ tests $ \test -> do + log' $ concat + [ "Test run " + , namever + , " (" + , pack test + , ")" + ] + let exe = "dist/build" test test - exists <- liftIO $ doesFileExist $ childDir exe - if exists - then do - mres <- timeout maximumTestSuiteTime $ run (pack exe) [] - case mres of - Just () -> return () - Nothing -> error $ concat - [ "Test suite timed out: " - , unpack namever - , ":" - , test - ] - else do - outH <- getOutH - hPut outH $ encodeUtf8 $ asText $ "Test suite not built: " ++ pack test + exists <- liftIO $ doesFileExist $ childDir exe + if exists + then do + mres <- timeout maximumTestSuiteTime $ run (pack exe) [] + case mres of + Just () -> return () + Nothing -> error $ concat + [ "Test suite timed out: " + , unpack namever + , ":" + , test + ] + else do + outH <- getOutH + hPut outH $ encodeUtf8 $ asText $ "Test suite not built: " ++ pack test + else return $ Right () - 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 () + 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 () buildBenches withUnpacked = wf benchOut $ \getOutH -> do prevBenchResult <- getPreviousResult pb Bench pident - let needTest = pbEnableBenches + let needBench = pbEnableBenches && checkPrevResult prevBenchResult pcBenches && not pcSkipBuild - when needTest $ withUnpacked $ \_gpd childDir -> do - let run = runIn childDir getOutH - cabal = setup run + hasBenches = not . null . condBenchmarks + when needBench $ withUnpacked "needBench" $ \gpd childDir -> do + -- See explanation for this above in the test section + eres <- + if hasBenches gpd + then do + let run = runIn childDir getOutH + cabal = setup run - log' $ "Benchmark configure " ++ namever - cabal $ "configure" : "--enable-benchmarks" : configArgs + log' $ "Benchmark configure " ++ namever + cabal $ "configure" : "--enable-benchmarks" : configArgs - eres <- tryAny $ do - log' $ "Benchmark build " ++ namever - cabal ["build"] + tryAny $ do + log' $ "Benchmark build " ++ namever + cabal ["build"] - savePreviousResult pb Bench pident $ either (const False) (const True) eres - case (eres, pcBenches) of - (Left e, ExpectSuccess) -> throwM e - (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected benchmark success" - _ -> return () + else return $ Right () + savePreviousResult pb Bench pident $ either (const False) (const True) eres + case (eres, pcBenches) of + (Left e, ExpectSuccess) -> throwM e + (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected benchmark success" + _ -> return () + + warn t = atomically $ modifyTVar sbWarningsVar (. (t:)) updateErrs exc = do @@ -950,7 +980,7 @@ writeGenericPackageDescription cabalFP gpd return gpd else return gpd' - let simple = buildType (packageDescription gpd) == Just Simple + let simple = buildType (packageDescription gpd) == Simple when simple $ do _ <- tryIO' $ removeFile $ fromString setuplhs writeFile setuphs $ asByteString "import Distribution.Simple\nmain = defaultMain\n" diff --git a/Stackage/Types.hs b/Stackage/Types.hs --- a/Stackage/Types.hs +++ b/Stackage/Types.hs @@ -268,6 +268,9 @@ , pcHide :: !Bool -- ^ Hide this package after registering, useful for avoiding -- module name conflicts + , pcNonParallelBuild :: !Bool + -- ^ Is this package so resource intensive that it should be built + -- in a non-parallel manner? } deriving (Show, Eq) instance ToJSON PackageConstraints where @@ -288,6 +291,7 @@ , "skip-build" .= pcSkipBuild , "configure-args" .= pcConfigureArgs , "hide" .= pcHide + , "non-parallel-build" .= pcNonParallelBuild ] where addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer @@ -307,6 +311,7 @@ pcSkipBuild <- o .:? "skip-build" .!= False pcConfigureArgs <- o .:? "configure-args" .!= mempty pcHide <- o .:? "hide" .!= False + pcNonParallelBuild <- o .:? "non-parallel-build" .!= False return PackageConstraints {..} data TestState = ExpectSuccess diff --git a/Stackage/UpdateBuildPlan.hs b/Stackage/UpdateBuildPlan.hs --- a/Stackage/UpdateBuildPlan.hs +++ b/Stackage/UpdateBuildPlan.hs @@ -45,6 +45,7 @@ , pcEnableLibProfile = maybe True pcEnableLibProfile moldPC , pcSkipBuild = maybe False pcSkipBuild moldPC , pcHide = maybe False pcHide moldPC + , pcNonParallelBuild = maybe False pcNonParallelBuild moldPC } where moldBP = lookup name bpPackages 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.15.1.0 +version: 0.16.0.0 synopsis: Tools for curating Stackage bundles description: Please see for a description and documentation. homepage: https://github.com/fpco/stackage-curator @@ -41,7 +41,7 @@ Stackage.Types build-depends: base >= 4 && < 5 , containers - , Cabal >= 2.0 && < 2.1 + , Cabal >= 2.2 && < 2.3 , tar >= 0.3 , zlib , bytestring @@ -54,7 +54,7 @@ , utf8-string , conduit-extra - , classy-prelude-conduit >= 0.12 + , classy-prelude-conduit >= 1 , text , system-fileio , system-filepath @@ -122,7 +122,7 @@ , optparse-applicative , optparse-simple , text - , aeson + , aeson >= 1 default-language: Haskell2010 other-extensions: TemplateHaskell diff --git a/test/Stackage/BuildPlanSpec.hs b/test/Stackage/BuildPlanSpec.hs --- a/test/Stackage/BuildPlanSpec.hs +++ b/test/Stackage/BuildPlanSpec.hs @@ -63,7 +63,7 @@ bc <- readPlanFile man plans <- getPlans bc allCabalHashesCommit <- getAllCabalHashesCommit - bp <- newBuildPlan allCabalHashesCommit plans mempty bc + bp <- newBuildPlan allCabalHashesCommit plans testLatestPackages bc let bs = Y.encode bp ebp' = Y.decodeEither bs @@ -126,7 +126,8 @@ ,pcFlagOverrides = mempty ,pcEnableLibProfile = False ,pcSkipBuild = False - ,pcHide = False} + ,pcHide = False + ,pcNonParallelBuild = False} ,ppDesc = SimpleDesc {sdPackages = deps @@ -150,3 +151,9 @@ decodeFileEither fp >>= either throwIO toBC where fp = "test/test-build-constraints.yaml" + +-- | Test package set with versions. +testLatestPackages :: Map PackageName Version +testLatestPackages = + Map.fromList [ (mkPackageName n, mkVersion [0, 0, 0]) + | n <- ["bar", "foo", "mu"] ]