diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +## 0.13.0 + +* build-tool-overrides +* Avoid using the cabal-install executable [stackage#1107](https://github.com/fpco/stackage/issues/1107) + ## 0.12.0 * New create-plan flags: `--add-package`, `--expect-test-failure` and `--expect-haddock-failure` diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs --- a/Stackage/BuildConstraints.hs +++ b/Stackage/BuildConstraints.hs @@ -39,6 +39,12 @@ , bcGithubUsers :: Map Text (Set Text) -- ^ map an account to set of pingees + + , bcBuildToolOverrides :: Map Text (Set Text) + -- ^ map a build tool name to a set of packages we should include + -- + -- Used to avoid situations like extra packages on Hackage providing the + -- cabal executable } -- | Modify the version bounds with the given Dependencies @@ -109,6 +115,7 @@ , cfSkippedBenchmarks :: Set PackageName , cfPackages :: Map Maintainer (Vector Dependency) , cfGithubUsers :: Map Text (Set Text) + , cfBuildToolOverrides :: Map Text (Set Text) , cfSkippedLibProfiling :: Set PackageName , cfGhcMajorVersion :: Maybe (Int, Int) , cfTreatAsNonCore :: Set PackageName @@ -127,6 +134,7 @@ >>= mapM (mapM toDep) . Map.mapKeysWith const Maintainer cfGithubUsers <- o .: "github-users" + cfBuildToolOverrides <- o .:? "build-tool-overrides" .!= mempty cfGhcMajorVersion <- o .:? "ghc-major-version" >>= mapM parseMajorVersion cfTreatAsNonCore <- getPackages o "treat-as-non-core" <|> return mempty return ConstraintFile {..} @@ -197,3 +205,4 @@ pcSkipBuild = name `member` cfSkippedBuilds bcGithubUsers = cfGithubUsers + bcBuildToolOverrides = cfBuildToolOverrides diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs --- a/Stackage/BuildPlan.hs +++ b/Stackage/BuildPlan.hs @@ -20,6 +20,7 @@ import Control.Monad.State.Strict (execState, get, put) import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Distribution.Compiler import Distribution.PackageDescription import Stackage.BuildConstraints @@ -31,7 +32,8 @@ -- | 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 - let toolMap = makeToolMap packagesOrig + let toolMap :: Map ExeName (Set PackageName) + toolMap = makeToolMap bcBuildToolOverrides packagesOrig packages = populateUsers $ removeUnincluded bc toolMap packagesOrig toolNames :: [ExeName] toolNames = concatMap (Map.keys . sdTools . ppDesc) packages @@ -47,19 +49,25 @@ , bpTools = tools , bpPackages = packages , bpGithubUsers = bcGithubUsers + , bpBuildToolOverrides = bcBuildToolOverrides } where SystemInfo {..} = bcSystemInfo -makeToolMap :: Map PackageName PackagePlan +makeToolMap :: Map Text (Set Text) -- ^ build tool overrides + -> Map PackageName PackagePlan -> Map ExeName (Set PackageName) -makeToolMap = - unionsWith (++) . map go . mapToList +makeToolMap overrides = + (overrides' ++) . unionsWith (++) . map go . mapToList where go (packageName, pp) = foldMap go' $ sdProvidedExes $ ppDesc pp where go' exeName = singletonMap exeName (singletonSet packageName) + + overrides' :: Map ExeName (Set PackageName) + overrides' = Map.mapKeysWith (++) ExeName + $ fmap (Set.map mkPackageName) overrides topologicalSortTools :: MonadThrow m => Map ExeName (Set PackageName) diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -459,10 +459,10 @@ plan <- decodeFileEither planFile >>= either throwM return - cabalDir <- getAppUserDataDirectory "cabal" - parMapM_ 8 (download man cabalDir) $ mapToList $ bpPackages plan + stackDir <- getAppUserDataDirectory "stack" + parMapM_ 8 (download man stackDir) $ mapToList $ bpPackages plan where - download man cabalDir (display -> name, display . ppVersion -> version) = do + download man stackDir (display -> name, display . ppVersion -> version) = do unlessM (isFile fp) $ do hPut stdout $ encodeUtf8 $ concat [ "Downloading " @@ -485,12 +485,7 @@ , version , ".tar.gz" ] - fp = fromString $ cabalDir - "packages" - "hackage.haskell.org" - unpack name - unpack version - unpack (concat [name, "-", version, ".tar.gz"]) + fp = sdistFilePath stackDir name version parMapM_ :: (MonadIO m, MonadBaseUnlift IO m, MonoFoldable mono) => Int diff --git a/Stackage/PackageIndex.hs b/Stackage/PackageIndex.hs --- a/Stackage/PackageIndex.hs +++ b/Stackage/PackageIndex.hs @@ -17,6 +17,7 @@ , SimplifiedPackageDescription (..) , SimplifiedComponentInfo (..) , getLatestDescriptions + , gpdFromLBS ) where import qualified Codec.Archive.Tar as Tar @@ -32,7 +33,6 @@ import Distribution.ParseUtils (PError) import Distribution.System (Arch, OS) import Stackage.Prelude -import Stackage.Update import Stackage.GithubPings import System.Directory (doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing) import System.FilePath (takeDirectory) @@ -46,32 +46,10 @@ -- | Name of the 00-index.tar downloaded from Hackage. getPackageIndexPath :: MonadIO m => m FilePath getPackageIndexPath = liftIO $ do - c <- getCabalRoot - let configFile = c "config" - exists <- liftIO $ doesFileExist configFile - remoteCache <- if exists - then do - configLines <- runResourceT $ sourceFile (c "config") - $$ decodeUtf8C - =$ linesUnboundedC - =$ concatMapC getRemoteCache - =$ sinkList - case configLines of - [x] -> return x - [] -> error $ "No remote-repo-cache found in Cabal config file" - _ -> error $ "Multiple remote-repo-cache entries found in Cabal config file" - else return $ c "packages" - - let tarball = remoteCache "hackage.haskell.org" "00-index.tar" - - unlessM (liftIO $ doesFileExist tarball) $ - stackageUpdate defaultStackageUpdateSettings - + stackRoot <- getAppUserDataDirectory "stack" + let tarball = stackRoot "indices" "Hackage" "00-index.tar" return tarball where - getCabalRoot :: IO FilePath - getCabalRoot = getAppUserDataDirectory "cabal" - getRemoteCache s = do ("remote-repo-cache", stripPrefix ":" -> Just v) <- Just $ break (== ':') s Just $ unpack $ T.strip v @@ -197,17 +175,24 @@ cache = root "cache" (unpack $ decodeUtf8 $ B16.encode $ SHA256.hashlazy lbs) -- Parse the desc from the contents of the .cabal file - parseFromText = - case parsePackageDescription $ unpack $ dropBOM $ decodeUtf8 lbs of - ParseFailed e -> throwM $ CabalParseException fp e - ParseOk _warnings gpd -> do - let pd = packageDescription gpd - PackageIdentifier name' version' = package pd - when (name /= name' || version /= version') $ - throwM $ MismatchedNameVersion fp - name name' version version' - return $ gpdToSpd gpd + parseFromText = do + gpd <- gpdFromLBS fp lbs + let pd = packageDescription gpd + PackageIdentifier name' version' = package pd + when (name /= name' || version /= version') $ + throwM $ MismatchedNameVersion fp + name name' version version' + return $ gpdToSpd gpd +gpdFromLBS :: MonadThrow m + => FilePath + -> 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 diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -11,6 +11,7 @@ , PerformBuild (..) , BuildException (..) , pbDocDir + , sdistFilePath ) where import Control.Concurrent.Async (async) @@ -18,6 +19,7 @@ import Control.Monad.Writer.Strict (execWriter, tell) import qualified Data.Map as Map import Data.NonNull (fromNullable) +import Distribution.PackageDescription (buildType, packageDescription, BuildType (Simple)) import Filesystem (canonicalizePath, createTree, getWorkingDirectory, removeTree, rename, removeFile) @@ -27,8 +29,10 @@ import Stackage.BuildPlan import Stackage.GhcPkg import Stackage.PackageDescription +import Stackage.PackageIndex (gpdFromLBS) import Stackage.Prelude hiding (pi) -import System.Directory (doesDirectoryExist, doesFileExist, findExecutable) +import System.Directory (doesDirectoryExist, doesFileExist, findExecutable, + getAppUserDataDirectory) import qualified System.FilePath as FP import System.Environment (getEnvironment) import System.Exit @@ -172,7 +176,7 @@ sem <- atomically $ newTSem pbJobs active <- newTVarIO (0 :: Int) - let toolMap = makeToolMap $ bpPackages pbPlan + let toolMap = makeToolMap (bpBuildToolOverrides pbPlan) (bpPackages pbPlan) packageMap <- fmap fold $ forM (mapToList $ bpPackages pbPlan) $ \(name, plan) -> do let piPlan = plan @@ -265,11 +269,11 @@ singleBuild :: PerformBuild -> Set PackageName -- ^ registered packages -> SingleBuild -> IO () -singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = - withCounter sbActive - $ handle updateErrs - $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False)) - $ inner +singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = do + withCounter sbActive + $ handle updateErrs + $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False)) + $ inner where libComps = setFromList [CompLibrary, CompExecutable] testComps = insertSet CompTestSuite libComps @@ -284,10 +288,11 @@ pname = piName sbPackageInfo pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo) name = display pname + version = display $ ppVersion $ piPlan sbPackageInfo namever = concat [ name , "-" - , display $ ppVersion $ piPlan sbPackageInfo + , version ] runIn wdir getOutH cmd args = do @@ -337,6 +342,14 @@ inner' getH `finally` cleanup + runghcArgs :: [Text] -> [Text] + runghcArgs rest = + "-clear-package-db" + : "-global-package-db" + : (case pbDatabase pb of + Nothing -> rest + Just db -> ("-package-db=" ++ pack db) : rest) + configArgs = ($ []) $ execWriter $ do when pbAllowNewer $ tell' "--allow-newer" tell' "--package-db=clear" @@ -372,12 +385,15 @@ buildLibrary = wf libOut $ \getOutH -> do let run a b = do when pbVerbose $ log' (unwords (a : b)) runChild getOutH a b + cabal args = run "runghc" $ runghcArgs $ "Setup" : args isUnpacked <- newIORef False let withUnpacked inner' = do unlessM (readIORef isUnpacked) $ do log' $ "Unpacking " ++ namever - runParent getOutH "cabal" ["unpack", namever] + runParent getOutH "stack" ["unpack", namever] + + createSetupHs childDir name writeIORef isUnpacked True inner' @@ -385,7 +401,7 @@ let withConfiged inner' = withUnpacked $ do unlessM (readIORef isConfiged) $ do log' $ "Configuring " ++ namever - run "cabal" $ "configure" : configArgs + cabal $ "configure" : configArgs writeIORef isConfiged True inner' @@ -406,12 +422,12 @@ deletePreviousResults pb pident log' $ "Building " ++ namever - run "cabal" ["build"] + cabal ["build"] log' $ "Copying/registering " ++ namever - run "cabal" ["copy"] + cabal ["copy"] withMVar sbRegisterMutex $ const $ - run "cabal" ["register"] + cabal ["register"] savePreviousResult pb Build pident True @@ -458,7 +474,7 @@ when pbBuildHoogle $ tell' "--hoogle" tell' "--html-location=../$pkg-$version/" - eres <- tryAny $ run "cabal" args + eres <- tryAny $ cabal args forM_ eres $ \() -> do renameOrCopy @@ -487,6 +503,7 @@ runTests withUnpacked = wf testOut $ \getOutH -> do let run = runChild getOutH + cabal args = run "runghc" $ runghcArgs $ "Setup" : args prevTestResult <- getPreviousResult pb Test pident let needTest = pbEnableTests @@ -494,14 +511,14 @@ && not pcSkipBuild when needTest $ withUnpacked $ do log' $ "Test configure " ++ namever - run "cabal" $ "configure" : "--enable-tests" : configArgs + cabal $ "configure" : "--enable-tests" : configArgs eres <- tryAny $ do log' $ "Test build " ++ namever - run "cabal" ["build"] + cabal ["build"] log' $ "Test run " ++ namever - run "cabal" ["test", "--log=" ++ pack testRunOut] + cabal ["test", "--log=" ++ pack testRunOut] savePreviousResult pb Test pident $ either (const False) (const True) eres case (eres, pcTests) of @@ -646,3 +663,40 @@ isLibExe DepInfo {..} = CompLibrary `member` diComponents || CompExecutable `member` diComponents + +sdistFilePath :: IsString filepath + => FilePath -- ^ stack directory + -> Text -- ^ package name + -> Text -- ^ package name + -> filepath +sdistFilePath stackDir name version = fromString + $ stackDir + "indices" + "Hackage" + "packages" + unpack name + unpack version + unpack (concat [name, "-", version, ".tar.gz"]) + +-- | Create a default Setup.hs file if the given directory is a simple build plan +-- +-- Also deletes any Setup.lhs if necessary +createSetupHs :: FilePath + -> Text -- ^ package name + -> IO () +createSetupHs dir name = do + simple <- isSimple cabalFP + when simple $ do + _ <- tryIO $ removeFile $ fromString setuplhs + writeFile setuphs $ asByteString "import Distribution.Simple\nmain = defaultMain\n" + where + cabalFP = dir unpack name <.> "cabal" + setuphs = dir "Setup.hs" + setuplhs = dir "Setup.lhs" + +-- | Check if the given cabal file has a simple build plan +isSimple :: FilePath -> IO Bool +isSimple fp = do + bs <- readFile fp + gpd <- gpdFromLBS fp (fromStrict bs) + return $ buildType (packageDescription gpd) == Just Simple diff --git a/Stackage/UpdateBuildPlan.hs b/Stackage/UpdateBuildPlan.hs --- a/Stackage/UpdateBuildPlan.hs +++ b/Stackage/UpdateBuildPlan.hs @@ -26,6 +26,7 @@ bcSystemInfo = bpSystemInfo bcPackages = Map.keysSet bpPackages bcGithubUsers = bpGithubUsers + bcBuildToolOverrides = bpBuildToolOverrides bcPackageConstraints name = PackageConstraints { pcVersionRange = addBumpRange (maybe anyVersion pcVersionRange moldPC) diff --git a/app/stackage.hs b/app/stackage.hs --- a/app/stackage.hs +++ b/app/stackage.hs @@ -15,8 +15,8 @@ import Stackage.InstallBuild import Stackage.Prelude hiding ((<>)) import Stackage.Stats -import Stackage.Update import Stackage.Upload +import System.Exit (exitWith) import System.IO (BufferMode (LineBuffering), hSetBuffering) main :: IO () @@ -30,8 +30,10 @@ commands where commands = do - addCommand "update" "Update the package index" id - (pure $ stackageUpdate defaultStackageUpdateSettings) + addCommand "update" "DEPRECATED use stack update instead" id + (pure $ do + putStrLn $ pack "Deprecated, use 'stack update' directly instead" + rawSystem "stack" ["update"] >>= exitWith) addCommand "create-plan" "Generate a new plan file (possibly based on a previous LTS)" id (createPlan <$> target 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.12.0 +version: 0.13.0 synopsis: Tools for curating Stackage bundles description: Please see for a description and documentation. homepage: https://github.com/fpco/stackage @@ -71,7 +71,7 @@ , semigroups , xml-conduit , conduit - , stackage-types >= 1.1 + , stackage-types >= 1.2 , monad-unlift >= 0.1.1 , blaze-html @@ -89,7 +89,6 @@ , stackage-metadata >= 0.3 , stackage-install >= 0.1.1 , lucid - , stackage-update , binary , binary-tagged @@ -103,7 +102,6 @@ , stackage-curator , optparse-applicative >= 0.11 , optparse-simple - , stackage-update , stackage-cli , system-filepath , http-client