stackage-curator 0.14.1.1 → 0.14.3
raw patch · 19 files changed
+358/−46 lines, 19 filesdep ~http-client
Dependency ranges changed: http-client
Files
- ChangeLog.md +12/−0
- Stackage/BuildConstraints.hs +11/−0
- Stackage/BuildPlan.hs +33/−3
- Stackage/CheckBuildPlan.hs +8/−6
- Stackage/CompleteBuild.hs +8/−6
- Stackage/Curator/UploadDocs.hs +34/−2
- Stackage/DiffPlans.hs +1/−1
- Stackage/GhcPkg.hs +2/−2
- Stackage/InstallBuild.hs +1/−1
- Stackage/PackageIndex.hs +20/−4
- Stackage/PerformBuild.hs +206/−11
- Stackage/ShowBuildPlan.hs +2/−2
- Stackage/Types.hs +4/−0
- Stackage/UpdateBuildPlan.hs +6/−2
- Stackage/Upload.hs +2/−2
- stackage-curator.cabal +2/−2
- test/Stackage/BuildPlanSpec.hs +3/−1
- test/Stackage/PackageIndexSpec.hs +1/−1
- test/test-build-constraints.yaml +2/−0
ChangeLog.md view
@@ -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)
Stackage/BuildConstraints.hs view
@@ -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
Stackage/BuildPlan.hs view
@@ -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)
Stackage/CheckBuildPlan.hs view
@@ -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)
Stackage/CompleteBuild.hs view
@@ -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
Stackage/Curator/UploadDocs.hs view
@@ -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
Stackage/DiffPlans.hs view
@@ -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
Stackage/GhcPkg.hs view
@@ -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
Stackage/InstallBuild.hs view
@@ -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
Stackage/PackageIndex.hs view
@@ -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)
Stackage/PerformBuild.hs view
@@ -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
Stackage/ShowBuildPlan.hs view
@@ -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
Stackage/Types.hs view
@@ -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 -> (,)
Stackage/UpdateBuildPlan.hs view
@@ -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)
Stackage/Upload.hs view
@@ -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 =
stackage-curator.cabal view
@@ -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 <http://www.stackage.org/package/stackage-curator> 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
test/Stackage/BuildPlanSpec.hs view
@@ -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
test/Stackage/PackageIndexSpec.hs view
@@ -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"
test/test-build-constraints.yaml view
@@ -18,3 +18,5 @@ package-flags: foo: demo: true++tell-me-when-its-released: []