From 8c66b224c1d04b61a83922a323af77101dee52f8 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Wed, 30 Aug 2023 01:32:23 +0100 Subject: [PATCH] Fix #6225 Avoid use of GHC_PACKAGE_PATH --- src/Stack/Build/Execute.hs | 62 ++++++++++++++++---------------------- src/Stack/GhcPkg.hs | 14 ++++++--- 2 files changed, 36 insertions(+), 40 deletions(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 63680b9c82..7d39421369 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -44,7 +44,7 @@ import Data.Conduit.Process.Typed ( createSource ) import qualified Data.Conduit.Text as CT import qualified Data.List as L import Data.List.NonEmpty ( nonEmpty ) -import qualified Data.List.NonEmpty as NonEmpty ( toList ) +import qualified Data.List.NonEmpty as NonEmpty import Data.List.Split ( chunksOf ) import qualified Data.Map.Merge.Strict as Map import qualified Data.Map.Strict as Map @@ -56,7 +56,6 @@ import Data.Time ( ZonedTime, getZonedTime, formatTime, defaultTimeLocale ) import qualified Data.ByteString.Char8 as S8 import qualified Distribution.PackageDescription as C -import Distribution.Pretty ( prettyShow ) import qualified Distribution.Simple.Build.Macros as C import Distribution.System ( OS (Windows), Platform (Platform) ) import qualified Distribution.Text as C @@ -85,10 +84,9 @@ import Path.IO import RIO.Process ( HasProcessContext, byteStringInput, doesExecutableExist , eceExitCode, findExecutable, getStderr, getStdout, inherit - , modifyEnvVars, proc, readProcess_, runProcess_, setStderr - , setStdin, setStdout, showProcessArgDebug, useHandleOpen - , waitExitCode, withModifyEnvVars, withProcessWait - , withWorkingDir + , modifyEnvVars, proc, runProcess_, setStderr, setStdin + , setStdout, showProcessArgDebug, useHandleOpen, waitExitCode + , withProcessWait, withWorkingDir ) import Stack.Build.Cache ( TestStatus (..), deleteCaches, getTestStatus @@ -123,7 +121,7 @@ import Stack.Coverage ( deleteHpcReports, generateHpcMarkupIndex, generateHpcReport , generateHpcUnifiedReport, updateTixFile ) -import Stack.GhcPkg ( ghcPkgPathEnvVar, unregisterGhcPkgIds ) +import Stack.GhcPkg ( ghcPkg, unregisterGhcPkgIds ) import Stack.Package ( buildLogPath ) import Stack.PackageDump ( conduitDumpPackage, ghcPkgDescribe ) import Stack.Prelude @@ -877,7 +875,7 @@ unregisterPackages cv localDB ids = do let unregisterSinglePkg select (gid, (ident, reason)) = do logReason ident reason pkg <- getGhcPkgExe - unregisterGhcPkgIds pkg localDB $ select ident gid :| [] + unregisterGhcPkgIds True pkg localDB $ select ident gid :| [] case cv of -- GHC versions >= 8.2.1 support batch unregistering of packages. See -- https://gitlab.haskell.org/ghc/ghc/issues/12637 @@ -897,7 +895,7 @@ unregisterPackages cv localDB ids = do for_ (chunksOfNE batchSize ids) $ \batch -> do for_ batch $ \(_, (ident, reason)) -> logReason ident reason pkg <- getGhcPkgExe - unregisterGhcPkgIds pkg localDB $ fmap (Right . fst) batch + unregisterGhcPkgIds True pkg localDB $ fmap (Right . fst) batch -- GHC versions >= 7.9 support unregistering of packages via their GhcPkgId. ACGhc v | v >= mkVersion [7, 9] -> @@ -1721,7 +1719,6 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap _ -> pure Nothing copyPreCompiled (PrecompiledCache mlib sublibs exes) = do - wc <- view $ actualCompilerVersionL.whichCompilerL announceTask ee task "using precompiled package" -- We need to copy .conf files for the main library and all sublibraries @@ -1736,39 +1733,32 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap toMungedPackageId sublib = let sublibName = LSubLibName $ mkUnqualComponentName $ T.unpack sublib in MungedPackageId (MungedPackageName pname sublibName) pversion + toPackageId :: MungedPackageId -> PackageIdentifier + toPackageId (MungedPackageId n v) = + PackageIdentifier (encodeCompatPackageName n) v + allToUnregister :: [Either PackageIdentifier GhcPkgId] allToUnregister = mcons - (prettyShow taskProvides <$ mlib) - (map (prettyShow . toMungedPackageId) subLibNames) + (Left taskProvides <$ mlib) + (map (Left . toPackageId . toMungedPackageId) subLibNames) allToRegister = mcons mlib sublibs unless (null allToRegister) $ withMVar eeInstallLock $ \() -> do - -- We want to ignore the global and user databases. - -- Unfortunately, ghc-pkg doesn't take such arguments on the - -- command line. Instead, we'll set GHC_PACKAGE_PATH. See: - -- https://github.com/commercialhaskell/stack/issues/1146 - - let modifyEnv = Map.insert - (ghcPkgPathEnvVar wc) - (T.pack $ toFilePathNoTrailingSep $ bcoSnapDB eeBaseConfigOpts) - - withModifyEnvVars modifyEnv $ do - GhcPkgExe ghcPkgExe <- getGhcPkgExe - - -- first unregister everything that needs to be unregistered - forM_ allToUnregister $ \packageName -> catchAny - ( readProcessNull - (toFilePath ghcPkgExe) - [ "unregister", "--force", packageName] + -- We want to ignore the global and user package databases. ghc-pkg + -- allows us to specify --no-user-package-db and --package-db= on + -- the command line. + let pkgDb = bcoSnapDB eeBaseConfigOpts + ghcPkgExe <- getGhcPkgExe + -- First unregister, silently, everything that needs to be unregistered. + unless (null allToUnregister) $ + catchAny + ( unregisterGhcPkgIds False ghcPkgExe pkgDb $ + NonEmpty.fromList allToUnregister ) (const (pure ())) - - -- now, register the cached conf files - forM_ allToRegister $ \libpath -> - proc - (toFilePath ghcPkgExe) - [ "register", "--force", toFilePath libpath] - readProcess_ + -- Now, register the cached conf files. + forM_ allToRegister $ \libpath -> + ghcPkg ghcPkgExe [pkgDb] ["register", "--force", toFilePath libpath] liftIO $ forM_ exes $ \exe -> do ensureDir bindir diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index a4184af5c2..39808a09f1 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -8,6 +8,7 @@ module Stack.GhcPkg ( createDatabase , findGhcPkgField , getGlobalDB + , ghcPkg , ghcPkgPathEnvVar , mkGhcPackagePath , unregisterGhcPkgIds @@ -139,18 +140,23 @@ findGhcPkgField pkgexe pkgDbs name field = do -- using GHC package id where available (from GHC 7.9) unregisterGhcPkgIds :: (HasProcessContext env, HasTerm env) - => GhcPkgExe + => Bool + -- ^ Report exceptions as warnings? + -> GhcPkgExe -> Path Abs Dir -- ^ package database -> NonEmpty (Either PackageIdentifier GhcPkgId) -> RIO env () -unregisterGhcPkgIds pkgexe pkgDb epgids = do +unregisterGhcPkgIds isWarn pkgexe pkgDb epgids = do + -- The ghcPkg function supplies initial arguments + -- --no-user-package-db --package-db= ... --package-db= eres <- ghcPkg pkgexe [pkgDb] args case eres of - Left e -> prettyWarn $ string $ displayException e + Left e -> when isWarn $ + prettyWarn $ string $ displayException e Right _ -> pure () where (idents, gids) = partitionEithers $ toList epgids - args = "unregister" : "--user" : "--force" : + args = "unregister" : "--force" : map packageIdentifierString idents ++ if null gids then [] else "--ipid" : map ghcPkgIdString gids