diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,15 @@ +## 0.14.3 + +* Much improved logic for calculating if a package needs to be rebuilt + due to rebuilding a dependency +* Include components using a dependency is check output + +## 0.14.2 + +* Add `all-cabal-hashes-commit` +* Add `tell-me-when-its-released` +* Fix warnings for `parseUrl` + ## 0.14.1.1 * Fix for latest nightly snapshot [#21](https://github.com/fpco/stackage-curator/issues/21) diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs --- a/Stackage/BuildConstraints.hs +++ b/Stackage/BuildConstraints.hs @@ -20,6 +20,7 @@ import Control.Monad.Writer.Strict (execWriter, tell) import Data.Aeson +import Data.Aeson.Internal ((), JSONPathElement (Key)) import qualified Data.Map as Map import Data.Yaml (decodeEither', decodeFileEither) import Distribution.Package (Dependency (..)) @@ -45,6 +46,8 @@ -- -- Used to avoid situations like extra packages on Hackage providing the -- cabal executable + + , bcTellMeWhenItsReleased :: Map PackageName Version } -- | Modify the version bounds with the given Dependencies @@ -121,6 +124,7 @@ , cfSkippedLibProfiling :: Set PackageName , cfGhcMajorVersion :: Maybe (Int, Int) , cfTreatAsNonCore :: Set PackageName + , cfTellMeWhenItsReleased :: Map PackageName Version } instance FromJSON ConstraintFile where @@ -142,6 +146,8 @@ cfBuildToolOverrides <- o .:? "build-tool-overrides" .!= mempty cfGhcMajorVersion <- o .:? "ghc-major-version" >>= mapM parseMajorVersion cfTreatAsNonCore <- getPackages o "treat-as-non-core" <|> return mempty + cfTellMeWhenItsReleased <- (fmap mconcat $ o .: "tell-me-when-its-released" >>= mapM toNameVerMap) + Key "tell-me-when-its-released" return ConstraintFile {..} where goFlagMap = Map.mapKeysWith const FlagName @@ -151,6 +157,10 @@ toDep :: Monad m => Text -> m Dependency toDep = either (fail . show) return . simpleParse + toNameVerMap :: Monad m => Text -> m (Map PackageName Version) + toNameVerMap = either (fail . show) (\(PackageIdentifier x y) -> return $ singletonMap x y) + . simpleParse + parseMajorVersion t = case versionBranch <$> simpleParse t of Just [x, y] -> return (x, y) @@ -215,3 +225,4 @@ bcGithubUsers = cfGithubUsers bcBuildToolOverrides = cfBuildToolOverrides + bcTellMeWhenItsReleased = cfTellMeWhenItsReleased diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs --- a/Stackage/BuildPlan.hs +++ b/Stackage/BuildPlan.hs @@ -29,8 +29,37 @@ import Stackage.Prelude -- | 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 +newBuildPlan :: MonadIO m + => Text -- ^ all-cabal-hashes repo commit + -> Map PackageName PackagePlan -- ^ latest allowed plans + -> Map PackageName Version -- ^ latest package version available + -> BuildConstraints + -> m BuildPlan +newBuildPlan allCabalHashesCommit packagesOrig packagesLatest bc@BuildConstraints {..} = liftIO $ do + let newReleased = mapMaybe checkReleased $ mapToList bcTellMeWhenItsReleased + checkReleased (name, expectedVersion) = + case lookup name packagesLatest of + Nothing -> Just $ concat + [ "No package version found for " + , display name + , ", expected version " + , display expectedVersion + ] + Just latestVersion + | latestVersion == expectedVersion -> Nothing + | otherwise -> Just $ concat + [ "Mismatched package version found for " + , display name + , ", expected version " + , display expectedVersion + , ", latest version " + , display latestVersion + ] + unless (null newReleased) $ do + putStrLn "The following packages have new releases (see tell-me-when-its-released):" + mapM_ putStrLn newReleased + error "Exiting due to presence of new releases" + let toolMap :: Map ExeName (Set PackageName) toolMap = makeToolMap bcBuildToolOverrides packagesOrig packages = populateUsers $ removeUnincluded bc toolMap packagesOrig @@ -49,6 +78,7 @@ , bpPackages = packages , bpGithubUsers = bcGithubUsers , bpBuildToolOverrides = bcBuildToolOverrides + , bpAllCabalHashesCommit = Just allCabalHashesCommit } where SystemInfo {..} = bcSystemInfo @@ -161,7 +191,7 @@ flags = mapWithKey overrideFlag $ spdPackageFlags spd overrideFlag name' defVal = fromMaybe defVal $ lookup name' overrides -getLatestAllowedPlans :: MonadIO m => BuildConstraints -> m (Map PackageName PackagePlan) +getLatestAllowedPlans :: MonadIO m => BuildConstraints -> m (Map PackageName PackagePlan, Map PackageName Version) getLatestAllowedPlans bc = getLatestDescriptions (isAllowed bc) diff --git a/Stackage/CheckBuildPlan.hs b/Stackage/CheckBuildPlan.hs --- a/Stackage/CheckBuildPlan.hs +++ b/Stackage/CheckBuildPlan.hs @@ -66,7 +66,7 @@ checkDeps getMaint allPackages (user, pb) = mapM_ go $ mapToList $ sdPackages $ ppDesc pb where - go (dep, diRange -> range) = + go (dep, depInfo@(DepInfo _ range)) = case lookup dep allPackages of Nothing -> tell $ BadBuildPlan (singletonMap (dep, getMaint dep, Nothing) errMap) mempty Just (version,deps) @@ -83,7 +83,7 @@ (dep, getMaint dep, Just version) errMap) mempty where - errMap = singletonMap pu range + errMap = singletonMap pu depInfo pu = PkgUser { puName = user , puVersion = ppVersion pb @@ -158,7 +158,7 @@ : map (cons '@') (setToList puGithubPings) data BadBuildPlan = BadBuildPlan - (Map (PackageName, Maybe Maintainer, Maybe Version) (Map PkgUser VersionRange)) + (Map (PackageName, Maybe Maintainer, Maybe Version) (Map PkgUser DepInfo)) (Map PackageName (Vector Text)) deriving Typeable instance Exception BadBuildPlan @@ -195,8 +195,8 @@ , ")" ] - showUser :: (PkgUser, VersionRange) -> Text - showUser (pu, range) = concat + showUser :: (PkgUser, DepInfo) -> Text + showUser (pu, (DepInfo comps range)) = concat [ "- [ ] " , pkgUserShow1 pu , " (" @@ -205,6 +205,8 @@ , T.replace "<" "< " $ display range , "). " , pkgUserShow2 pu + , ". Used by: " + , intercalate ", " $ map compToText $ setToList comps ] go2 :: (PackageName, Vector Text) -> Text @@ -215,5 +217,5 @@ instance Monoid BadBuildPlan where mempty = BadBuildPlan mempty mempty mappend (BadBuildPlan a x) (BadBuildPlan b y) = BadBuildPlan - (unionWith (unionWith intersectVersionRanges) a b) + (unionWith mappend a b) (unionWith mappend x y) diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -38,11 +38,12 @@ import Stackage.UpdateBuildPlan import Stackage.Upload import System.Environment (lookupEnv) -import Filesystem.Path (dropExtension) +import Filesystem.Path (dropExtension, filename) import Control.Monad.Trans.Unlift (askRunBase, MonadBaseUnlift) import Data.Function (fix) import Control.Concurrent.Async (Concurrently (..)) import Stackage.Curator.UploadDocs (uploadDocs) +import Stackage.PackageIndex (getAllCabalHashesCommit) import System.Directory (doesDirectoryExist, doesFileExist) -- | Flags passed in from the command line. @@ -88,7 +89,7 @@ , ".yaml" ] putStrLn $ "Downloading old plan from " ++ pack url - req <- parseUrl url + req <- parseUrlThrow url res <- httpLbs req man oldplan <- either throwM return $ decodeEither' (toStrict $ responseBody res) @@ -122,8 +123,9 @@ planFromConstraints :: MonadIO m => BuildConstraints -> m BuildPlan planFromConstraints bc = do putStrLn "Creating build plan" - plans <- getLatestAllowedPlans bc - newBuildPlan plans bc + (plans, latestVersions) <- getLatestAllowedPlans bc + allCabalHashesCommit <- getAllCabalHashesCommit + newBuildPlan allCabalHashesCommit plans latestVersions bc -- | Just print a message saying "still alive" every minute, to appease Travis. stillAlive :: IO () -> IO () @@ -360,7 +362,7 @@ sourceFile docmapFile $$ (sinkFile destFPDocmap :: Sink ByteString (ResourceT IO) ()) git ["add", destFPPlan, destFPDocmap] - git ["commit", "-m", "Checking in " ++ F.encodeString (dropExtension $ fromString destFPPlan)] + git ["commit", "-m", "Checking in " ++ F.encodeString (filename $ dropExtension $ fromString destFPPlan)] git ["push", "origin", "HEAD:master"] upload @@ -483,7 +485,7 @@ , "\n" ] createTree $ parent fp - req <- parseUrl url + req <- parseUrlThrow url withResponse req man $ \res -> do let tmp = F.encodeString fp <.> "tmp" runResourceT $ bodyReaderSource (responseBody res) $$ sinkFile tmp diff --git a/Stackage/Curator/UploadDocs.hs b/Stackage/Curator/UploadDocs.hs --- a/Stackage/Curator/UploadDocs.hs +++ b/Stackage/Curator/UploadDocs.hs @@ -23,6 +23,7 @@ import qualified Data.ByteString.Base16 as B16 import Data.Conduit.Zlib (WindowBits (WindowBits), compress) +import Data.Function (fix) import Data.XML.Types (Content (ContentText), Event (EventBeginDoctype, EventEndDoctype, EventBeginElement), Name) import Distribution.Package (PackageIdentifier (..)) @@ -67,10 +68,13 @@ $ set poCacheControl (Just "maxage=31536000") $ set poACL (Just OPublicRead) $ putObject (BucketName bucket) (ObjectKey name) (toBody body) - putStrLn $ "Sending " ++ name + + -- use ByteString output to ensure no interleaving of sending lines + hPut stdout $ encodeUtf8 $ "Sending " ++ name ++ "\n" _pors <- liftResourceT $ runAWS env $ send po return () + -- | Uses 'newEnv' for S3 credentials. uploadDocs :: FilePath -- ^ directory containing docs -> FilePath -- ^ the bundle file @@ -83,7 +87,34 @@ unlessM (Dir.doesDirectoryExist input') $ error $ "Could not find directory: " ++ show input' input <- fmap ( "") $ Dir.canonicalizePath input' - let inner = sourceDirectoryDeep False input $$ mapM_C (go input name) + let inner :: M m => m () + inner = do + let threads = 16 + size = threads * 2 + queue <- liftIO $ newTBQueueIO size + isOpenVar <- liftIO $ newTVarIO True + let readIO = liftIO $ atomically $ + (Just <$> readTBQueue queue) <|> + (do isOpen <- readTVar isOpenVar + checkSTM $ not isOpen + return Nothing) + close = liftIO $ atomically $ writeTVar isOpenVar False + + fillQueue = runResourceT $ + (sourceDirectoryDeep False input + $$ mapM_C (liftIO . atomically . writeTBQueue queue)) + `finally` close + + srcQueue = fix $ \loop -> do + mres <- readIO + case mres of + Nothing -> return () + Just res -> yield res >> loop + run <- askRunBase + liftIO $ runConcurrently $ + Concurrently fillQueue *> + sequence_ (asList $ replicate threads + (Concurrently (run $ srcQueue $$ mapM_C (go input name)))) runResourceT $ do ((), _, hoogles) <- runRWSIORefT inner (env, bucket) mempty @@ -206,6 +237,7 @@ type M m = ( MonadRWS (Env, Text) (Set FilePath) (Map FilePath Text, Set Text) m , MonadResource m + , MonadBaseUnlift IO m ) getName :: M m => FilePath -> m Text diff --git a/Stackage/DiffPlans.hs b/Stackage/DiffPlans.hs --- a/Stackage/DiffPlans.hs +++ b/Stackage/DiffPlans.hs @@ -89,7 +89,7 @@ getLTS lts = do createDirectoryIfMissing True tmpDir man <- newManager tlsManagerSettings - req <- parseUrl $ ltsRepo <> lts <> ".yaml" + req <- parseUrlThrow $ ltsRepo <> lts <> ".yaml" res <- httpLbs req man writeFile fName $ responseBody res return fName diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs --- a/Stackage/GhcPkg.hs +++ b/Stackage/GhcPkg.hs @@ -25,7 +25,7 @@ -> (ByteString -> IO ()) -- ^ logging -> Map PackageName Version -- ^ packages and versions to be installed -> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package - -> IO (Set PackageName) -- ^ packages remaining in the database after cleanup + -> IO (Map PackageName Version) -- ^ packages remaining in the database after cleanup setupPackageDatabase mdb docDir log' toInstall onUnregister = do registered1 <- getRegisteredPackages flags forM_ registered1 $ \pi'@(PackageIdentifier name version) -> @@ -34,7 +34,7 @@ _ -> return () broken <- getBrokenPackages flags forM_ broken $ unregisterPackage log' onUnregister docDir flags - foldMap (\(PackageIdentifier name _) -> singletonSet name) + foldMap (\(PackageIdentifier name version) -> singletonMap name version) <$> getRegisteredPackages flags where flags = ghcPkgFlags mdb diff --git a/Stackage/InstallBuild.hs b/Stackage/InstallBuild.hs --- a/Stackage/InstallBuild.hs +++ b/Stackage/InstallBuild.hs @@ -74,7 +74,7 @@ plan <- case ifPlanSource of BPSBundleWeb url -> do man <- newManager tlsManagerSettings - req <- parseUrl url + req <- parseUrlThrow url res <- httpLbs req man planBSL <- getPlanEntry $ Tar.read $ GZip.decompress (responseBody res) decodeBuildPlan planBSL diff --git a/Stackage/PackageIndex.hs b/Stackage/PackageIndex.hs --- a/Stackage/PackageIndex.hs +++ b/Stackage/PackageIndex.hs @@ -21,6 +21,7 @@ , SimplifiedComponentInfo (..) , getLatestDescriptions , gpdFromLBS + , getAllCabalHashesCommit ) where import qualified Codec.Archive.Tar as Tar @@ -56,6 +57,15 @@ let tarball = stackRoot "indices" "Hackage" "00-index.tar" return tarball +-- | Get the Git commit of the all-cabal-hashes repo at its current state +getAllCabalHashesCommit :: MonadIO m => m Text +getAllCabalHashesCommit = liftIO $ do + stackRoot <- getAppUserDataDirectory "stack" + let dir = stackRoot "indices" "Hackage" "git-update" "all-cabal-hashes" + cp = (proc "git" ["rev-list", "-n", "1", "current-hackage"]) { cwd = Just dir } + withCheckedProcessCleanup cp $ \ClosedStream out ClosedStream -> + out $$ takeWhileCE (/= 10) =$ decodeUtf8C =$ foldC + -- | A cabal file with name and version parsed from the filepath, and the -- package description itself ready to be parsed. It's left in unparsed form -- for efficiency. @@ -282,22 +292,28 @@ getLatestDescriptions :: MonadIO m => (PackageName -> Version -> Bool) -> (SimplifiedPackageDescription -> IO desc) - -> m (Map PackageName desc) + -> m (Map PackageName desc, Map PackageName Version) getLatestDescriptions f parseDesc = liftIO $ do root <- fmap ( "curator") $ getAppUserDataDirectory "stackage" -- Parse twice to avoid keeping stuff in memory: once to determine which -- versions to keep, once to do the actual parsing. liftIO $ putStrLn "Determining target package versions" - mvers <- runResourceT $ sourcePackageIndex $$ filterC f' =$ flip foldlC mempty - (\m ucf -> insertWith max (ucfName ucf) (ucfVersion ucf) m) + (mvers, latests) <- runResourceT $ sourcePackageIndex $$ getZipSink ((,) + -- get the latest, given the filter + <$> ZipSink (filterC f' =$ flip foldlC mempty + (\m ucf -> insertWith max (ucfName ucf) (ucfVersion ucf) m)) + -- get the absolute latest + <*> ZipSink (flip foldlC mempty + (\m ucf -> insertWith max (ucfName ucf) (ucfVersion ucf) m))) liftIO $ putStrLn "Parsing package descriptions" - runResourceT $ sourcePackageIndex $$ flip foldMC mempty + plans <- runResourceT $ sourcePackageIndex $$ flip foldMC mempty (\m ucf -> if lookup (ucfName ucf) (asMap mvers) == Just (ucfVersion ucf) then do desc <- liftIO $ ucfParse root ucf >>= parseDesc return $! insertMap (ucfName ucf) desc m else return m) + return (plans, latests) where f' ucf = f (ucfName ucf) (ucfVersion ucf) diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} module Stackage.PerformBuild ( performBuild , PerformBuild (..) @@ -39,6 +40,7 @@ import Stackage.PackageIndex (gpdFromLBS) import Stackage.Prelude hiding (pi) import System.Directory (doesDirectoryExist, doesFileExist, findExecutable, getDirectoryContents) +import qualified System.Directory import qualified System.FilePath as FP import System.Environment (getEnvironment) import System.Exit @@ -52,7 +54,7 @@ instance Exception BuildException instance Show BuildException where show (BuildException m warnings) = - unlines $ map go (mapToList m) ++ map unpack warnings + unlines $ "" : "" : "" : map go (mapToList m) ++ map unpack warnings where go (PackageName name, bf) = concat [ name @@ -196,12 +198,6 @@ sem <- atomically $ newTSem pbJobs active <- newTVarIO (0 :: Int) let toolMap = makeToolMap (bpBuildToolOverrides pbPlan) (bpPackages pbPlan) - packageMap <- fmap fold $ forM (mapToList $ bpPackages pbPlan) - $ \(name, plan) -> do - let piPlan = plan - piName = name - piResult <- newEmptyTMVarIO - return $ singletonMap name PackageInfo {..} errsVar <- newTVarIO mempty warningsVar <- newTVarIO id @@ -214,7 +210,17 @@ pbLog (ppVersion <$> bpPackages pbPlan) (deletePreviousResults pb) + allPreviousResults <- getAllPreviousResults pb + packageMap' <- fmap fold $ forM (mapToList $ bpPackages pbPlan) + $ \(name, plan) -> do + let piPlan = plan + piName = name + piResult <- newEmptyTMVarIO + return $ asMap $ singletonMap name PackageInfo {..} + + packageMap <- calculatePackageMap pb registeredPackages allPreviousResults packageMap' + pbLog "Collecting existing .haddock files\n" haddockFiles <- getHaddockFiles pb >>= newTVarIO haddockDeps <- newTVarIO mempty @@ -286,7 +292,7 @@ } singleBuild :: PerformBuild - -> Set PackageName -- ^ registered packages + -> Map PackageName Version -- ^ registered packages -> SingleBuild -> IO () singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = do withCounter sbActive @@ -743,6 +749,48 @@ successBS = "success" failureBS = "failure" +getAllPreviousResults :: PerformBuild -> IO (PackageName -> ResultType -> Maybe (Version, PrevResult)) +getAllPreviousResults pb = do + m <- fmap fold $ forM [minBound..maxBound] $ \rt -> asMap . singletonMap rt <$> go rt + return $ \pn rt -> lookup rt m >>= lookup pn + where + go :: ResultType -> IO (Map PackageName (Version, PrevResult)) + go rt = do + allResults <- + runResourceT + $ sourceDirectory dir + $$ filterMC (liftIO . doesFileExist) + =$ mapMC (liftIO . toMap) + =$ foldlC (unionWith union) mempty + fmap concat $ mapM (uncurry removeDupes) $ mapToList allResults + where + dir = pbPrevResDir pb show rt + + toMap :: FilePath -> IO (Map PackageName (Map Version PrevResult)) + toMap fp = do + case simpleParse $ pack $ FP.takeFileName fp of + Nothing -> return mempty + Just (PackageIdentifier name version) -> do + eres <- tryIO' $ readFile fp + let mres = + case eres of + Right bs + | bs == successBS -> Just PRSuccess + | bs == failureBS -> Just PRFailure + _ -> Nothing + case mres of + Nothing -> return mempty + Just res -> return $ singletonMap name (singletonMap version res) + + removeDupes :: PackageName -> Map Version PrevResult -> IO (Map PackageName (Version, PrevResult)) + removeDupes name m = + case mapToList m of + [] -> assert False $ return mempty + [pair] -> return $ singletonMap name pair + _pairs -> do + removePreviousResults pb rt name + return mempty + getPreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> IO PrevResult getPreviousResult w x y = withPRPath w x y $ \fp -> do eres <- tryIO' $ readFile fp @@ -752,10 +800,28 @@ | bs == failureBS -> PRFailure _ -> PRNoResult +-- | Remove all previous results to avoid a broken cache +removePreviousResults :: PerformBuild -> ResultType -> PackageName -> IO () +removePreviousResults pb rt name = + runResourceT + $ sourceDirectory dir + $$ filterC isOurPackage + =$ filterMC (liftIO . doesFileExist) + =$ mapM_C (liftIO . System.Directory.removeFile) + where + dir = pbPrevResDir pb show rt + prefix = display name ++ "-" + + isOurPackage fp = fromMaybe False $ do + versionT <- stripPrefix prefix $ pack $ FP.takeFileName fp + _ :: Version <- simpleParse versionT + return True + savePreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> Bool -> IO () -savePreviousResult pb rt ident res = - withPRPath pb rt ident $ \fp -> writeFile fp $ - if res then successBS else failureBS +savePreviousResult pb rt ident@(PackageIdentifier name _version) res = + withPRPath pb rt ident $ \fp -> do + removePreviousResults pb rt name + writeFile fp $ if res then successBS else failureBS deletePreviousResults :: PerformBuild -> PackageIdentifier -> IO () deletePreviousResults pb name = @@ -872,3 +938,132 @@ catchIO' :: IO a -> (IOException -> IO a) -> IO a catchIO' = catch + +data BuildState = BSFullBuild | BSPartialBuild | NoBuild + deriving Show + +calculatePackageMap :: PerformBuild + -> Map PackageName Version -- ^ registered libraries + -> (PackageName -> ResultType -> Maybe (Version, PrevResult)) + -> Map PackageName PackageInfo + -> IO (Map PackageName PackageInfo) +calculatePackageMap pb registered prevRes allInfos = + loop initBuildStates + where + -- Calculate initial build states based on whether packages are + -- registered and previous results. This will not take into + -- account dependencies, which will be calculate by loop + initBuildStates :: Map PackageName BuildState + initBuildStates = + foldMap go $ mapToList allInfos + where + go :: (PackageName, PackageInfo) -> Map PackageName BuildState + go (name, info) + -- If we're not going to build it, then don't build it + | pcSkipBuild (ppConstraints plan) = singletonMap name NoBuild + + -- If this is a library and it's not registered, then we + -- need to do a full build + | isLib && lookup name registered /= Just version = singletonMap name BSFullBuild + + -- If we have a previous successful build result which + -- matches our version, then we'll need to check + -- dependencies to know what to do + | Just (prevVer, prevRes) <- prevRes name Build + , prevVer == version && prevRes == PRSuccess = mempty + + -- Something in the previous step failed, so do a full build + | otherwise = singletonMap name BSFullBuild + where + isLib = not $ null $ sdModules $ ppDesc plan + version = ppVersion plan + plan = piPlan info + + loop buildStates0 = do + buildStates1 <- foldM step' buildStates0 (mapToList allInfos) + case (keys $ buildStates1 `difference` buildStates0, keys $ allInfos `Map.difference` buildStates1) of + -- Added new build states, and no infos are unaccounted for, so + -- we're done + (_:_, []) -> processBuildStates buildStates1 + + -- Added new build states, but we still have some unaccounted for + -- packages, so loop + (_:_, _:_) -> loop buildStates1 + + -- Did not add any build states, but somehow all the infos are + -- accounted for. This is logically impossible, print an error. + ([], []) -> do + putStrLn $ "\n\ncalculatePackageMap: Solved all packages, but no change in build states" + mapM_ print $ mapToList buildStates1 + putStrLn $ "\n\nPreviously missing packages:" ++ tshow (map display $ keys $ allInfos `Map.difference` buildStates0) + error "FIXME" + + -- Did not add any build states, and we still have some infos + -- unaccounted for. That indicates some kind of cyclic dependency. + ([], noBuildState) -> error $ "calculatePackageMap: No change in build states, but haven't solved all packages: " ++ show (map display noBuildState) + where + step' buildStates (name, info) = do + res <- step buildStates name info + return $ + case res of + Nothing -> buildStates + Just bs -> insertMap name bs buildStates + + step :: Map PackageName BuildState -> PackageName -> PackageInfo -> IO (Maybe BuildState) + step states name pi = + go $ keys $ Map.filter ((CompLibrary `member`) . diComponents) $ sdPackages desc + where + plan = piPlan pi + desc = ppDesc plan + + go (dep:deps) | dep == name = go deps + go (dep:deps) = + case lookup dep states of + -- Don't know what to do with a dep. Let's see if it's + -- actually in the build plan (as opposed to a core + -- library) + Nothing + -- It's in the build plan, so let's wait + | dep `member` allInfos -> do + when False $ putStrLn $ concat -- debugging + [ display name + , ": don't know state of dep: " + , tshow dep + ] + return Nothing + + -- Not in the build plan, so ignore and move on + -- (e.g., the base package) + | otherwise -> go deps + + -- dep will be rebuilt, so we need to be rebuilt too + Just BSFullBuild -> do + putStrLn $ concat + [ "Rebuilding " + , display name + , " due to dependency " + , display dep + ] + return $ Just BSFullBuild + + -- dep will not have its library rebuilt, so check the rest + Just BSPartialBuild -> go deps + Just NoBuild -> go deps + + -- none of the dependencies will have their libraries rebuilt + go [] = return $ Just BSPartialBuild -- FIXME figure out if we have no need to build at all NoBuild + + processBuildStates :: Map PackageName BuildState -> IO (Map PackageName PackageInfo) + processBuildStates buildStates = + fmap fold $ mapM go $ mapToList allInfos + where + go :: (PackageName, PackageInfo) -> IO (Map PackageName PackageInfo) + go (name, info) = + case lookup name buildStates of + Nothing -> error $ "processBuildStates: name not found " ++ show name + Just BSFullBuild -> do + putStrLn $ "Removing all previous results for " ++ display name + forM_ [minBound..maxBound] $ \rt -> removePreviousResults pb rt name + return $ singletonMap name info + Just BSPartialBuild -> return $ singletonMap name info + Just NoBuild -> return mempty diff --git a/Stackage/ShowBuildPlan.hs b/Stackage/ShowBuildPlan.hs --- a/Stackage/ShowBuildPlan.hs +++ b/Stackage/ShowBuildPlan.hs @@ -48,7 +48,7 @@ import Data.Yaml (decodeFileEither) import Distribution.Package (PackageName) import Network.HTTP.Client (Manager, brRead, httpLbs, - newManager, parseUrl, + newManager, parseUrlThrow, responseBody, withResponse) import Network.HTTP.Client.TLS (tlsManagerSettings) import Stackage.Types (BuildPlan (..), Component (..), @@ -277,7 +277,7 @@ download :: Manager -> CompleteSpec -> FilePath -> IO () download man spec dest = do - req <- parseUrl $ specUrl spec + req <- parseUrlThrow $ specUrl spec withResponse req man $ \res -> withBinaryFile dest WriteMode $ \h -> fix $ \loop -> do bs <- brRead $ responseBody res diff --git a/Stackage/Types.hs b/Stackage/Types.hs --- a/Stackage/Types.hs +++ b/Stackage/Types.hs @@ -29,6 +29,7 @@ , unFlagName , mkFlagName , intersectVersionRanges + , compToText ) where import Control.Applicative ((<|>)) @@ -122,11 +123,13 @@ , bpPackages :: Map PackageName PackagePlan , bpGithubUsers :: Map Text (Set Text) , bpBuildToolOverrides :: Map Text (Set Text) + , bpAllCabalHashesCommit :: Maybe Text } deriving (Show, Eq) instance ToJSON BuildPlan where toJSON BuildPlan {..} = object + $ maybe id (\x -> (("all-cabal-hashes-commit" .= x):)) bpAllCabalHashesCommit [ "system-info" .= bpSystemInfo , "tools" .= fmap goTool bpTools , "packages" .= Map.mapKeysWith const unPackageName bpPackages @@ -145,6 +148,7 @@ bpPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages") bpGithubUsers <- o .:? "github-users" .!= mempty bpBuildToolOverrides <- o .:? "build-tool-overrides" .!= mempty + bpAllCabalHashesCommit <- o .:? "all-cabal-hashes-commit" return BuildPlan {..} where goTool = withObject "Tool" $ \o -> (,) diff --git a/Stackage/UpdateBuildPlan.hs b/Stackage/UpdateBuildPlan.hs --- a/Stackage/UpdateBuildPlan.hs +++ b/Stackage/UpdateBuildPlan.hs @@ -13,11 +13,14 @@ orLaterVersion) import Stackage.BuildConstraints import Stackage.BuildPlan +import Stackage.PackageIndex import Stackage.Prelude updateBuildPlan :: Map PackageName PackagePlan -> BuildPlan -> IO BuildPlan -updateBuildPlan packagesOrig - = newBuildPlan packagesOrig . updateBuildConstraints +updateBuildPlan packagesOrig bp = do + allCabalHashesCommit <- getAllCabalHashesCommit + -- mempty, since when updating a build plan, we don't deal with tell-me-when-its-released + newBuildPlan allCabalHashesCommit packagesOrig mempty $ updateBuildConstraints bp updateBuildConstraints :: BuildPlan -> BuildConstraints updateBuildConstraints BuildPlan {..} = @@ -27,6 +30,7 @@ bcPackages = Map.keysSet bpPackages bcGithubUsers = bpGithubUsers bcBuildToolOverrides = bpBuildToolOverrides + bcTellMeWhenItsReleased = mempty -- we don't care when doing an update bcPackageConstraints name = PackageConstraints { pcVersionRange = addBumpRange (maybe anyVersion pcVersionRange moldPC) diff --git a/Stackage/Upload.hs b/Stackage/Upload.hs --- a/Stackage/Upload.hs +++ b/Stackage/Upload.hs @@ -35,7 +35,7 @@ -> Manager -> IO (Response LByteString) uploadHackageDistro name bp username password manager = do - req1 <- parseUrl $ concat + req1 <- parseUrlThrow $ concat [ "https://hackage.haskell.org/distro/" , unpack name , "/packages.csv" @@ -74,7 +74,7 @@ uploadBundleV2 UploadBundleV2 {..} man = IO.withBinaryFile ub2Bundle IO.ReadMode $ \h -> do size <- IO.hFileSize h putStrLn $ "Bundle size: " ++ tshow size - req1 <- parseUrl $ unpack $ unStackageServer ub2Server ++ "/upload2" + req1 <- parseUrlThrow $ unpack $ unStackageServer ub2Server ++ "/upload2" let req2 = req1 { method = "PUT" , requestHeaders = 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.14.1.1 +version: 0.14.3 synopsis: Tools for curating Stackage bundles description: Please see for a description and documentation. homepage: https://github.com/fpco/stackage-curator @@ -66,7 +66,7 @@ , aeson , yaml , unix-compat - , http-client + , http-client >= 0.4.30 , http-conduit , http-client-tls , temporary diff --git a/test/Stackage/BuildPlanSpec.hs b/test/Stackage/BuildPlanSpec.hs --- a/test/Stackage/BuildPlanSpec.hs +++ b/test/Stackage/BuildPlanSpec.hs @@ -14,6 +14,7 @@ import Stackage.BuildPlan import Stackage.CheckBuildPlan import Stackage.PackageDescription +import Stackage.PackageIndex import Stackage.Prelude import Stackage.UpdateBuildPlan import Test.Hspec @@ -61,7 +62,8 @@ man <- newManager tlsManagerSettings bc <- readPlanFile man plans <- getPlans bc - bp <- newBuildPlan plans bc + allCabalHashesCommit <- getAllCabalHashesCommit + bp <- newBuildPlan allCabalHashesCommit plans mempty bc let bs = Y.encode bp ebp' = Y.decodeEither bs diff --git a/test/Stackage/PackageIndexSpec.hs b/test/Stackage/PackageIndexSpec.hs --- a/test/Stackage/PackageIndexSpec.hs +++ b/test/Stackage/PackageIndexSpec.hs @@ -14,7 +14,7 @@ [ (asText "base", asText "4.5.0.0") , ("does-not-exist", "9999999999999999999") ]) - m <- getLatestDescriptions f return + (m, _) <- getLatestDescriptions f return length m `shouldBe` 1 p <- simpleParse $ asText "base" v <- simpleParse $ asText "4.5.0.0" diff --git a/test/test-build-constraints.yaml b/test/test-build-constraints.yaml --- a/test/test-build-constraints.yaml +++ b/test/test-build-constraints.yaml @@ -18,3 +18,5 @@ package-flags: foo: demo: true + +tell-me-when-its-released: []