stackage-curator 0.15.1.0 → 0.16.0.0
raw patch · 10 files changed
+164/−93 lines, 10 filesdep ~Cabaldep ~aesondep ~classy-prelude-conduit
Dependency ranges changed: Cabal, aeson, classy-prelude-conduit
Files
- ChangeLog.md +11/−0
- Stackage/BuildConstraints.hs +13/−2
- Stackage/BuildPlan.hs +12/−0
- Stackage/CompleteBuild.hs +1/−0
- Stackage/PackageIndex.hs +9/−16
- Stackage/PerformBuild.hs +99/−69
- Stackage/Types.hs +5/−0
- Stackage/UpdateBuildPlan.hs +1/−0
- stackage-curator.cabal +4/−4
- test/Stackage/BuildPlanSpec.hs +9/−2
ChangeLog.md view
@@ -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`
Stackage/BuildConstraints.hs view
@@ -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
Stackage/BuildPlan.hs view
@@ -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
Stackage/CompleteBuild.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}
Stackage/PackageIndex.hs view
@@ -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
Stackage/PerformBuild.hs view
@@ -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"
Stackage/Types.hs view
@@ -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
Stackage/UpdateBuildPlan.hs view
@@ -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
stackage-curator.cabal view
@@ -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 <http://www.stackage.org/package/stackage-curator> 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
test/Stackage/BuildPlanSpec.hs view
@@ -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"] ]