diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,1 +1,1 @@ -Please see https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.10.2.0.md +Please see https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.10.3.0.md diff --git a/cabal-install-solver.cabal b/cabal-install-solver.cabal --- a/cabal-install-solver.cabal +++ b/cabal-install-solver.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: cabal-install-solver -version: 3.10.2.1 +version: 3.10.3.0 synopsis: The command-line interface for Cabal and Hackage. description: The solver component used in cabal-install command-line program @@ -14,7 +14,7 @@ copyright: 2003-2023, Cabal Development Team category: Distribution build-type: Simple -Extra-Source-Files: +extra-doc-files: ChangeLog.md source-repository head @@ -109,12 +109,13 @@ , bytestring >=0.10.6.0 && <0.13 , Cabal ^>=3.10 , Cabal-syntax ^>=3.10 - , containers >=0.5.6.2 && <0.7 + , containers >=0.5.6.2 && <0.8 , edit-distance ^>= 0.2.2 - , filepath ^>=1.4.0.0 + , filepath ^>=1.4.0.0 || ^>=1.5.0.0 , mtl >=2.0 && <2.4 , pretty ^>=1.1 , transformers >=0.4.2.0 && <0.7 + , text (>= 1.2.3.0 && < 1.3) || (>= 2.0 && < 2.2) if flag(debug-expensive-assertions) cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS diff --git a/src/Distribution/Solver/Types/PkgConfigDb.hs b/src/Distribution/Solver/Types/PkgConfigDb.hs --- a/src/Distribution/Solver/Types/PkgConfigDb.hs +++ b/src/Distribution/Solver/Types/PkgConfigDb.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Solver.Types.PkgConfigDb @@ -23,17 +24,23 @@ import Distribution.Solver.Compat.Prelude import Prelude () -import Control.Exception (handle) -import Control.Monad (mapM) -import qualified Data.Map as M -import System.FilePath (splitSearchPath) +import Control.Exception (handle) +import Control.Monad (mapM) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import System.FilePath (splitSearchPath) import Distribution.Compat.Environment (lookupEnv) import Distribution.Package (PkgconfigName, mkPkgconfigName) import Distribution.Parsec import Distribution.Simple.Program (ProgramDb, getProgramOutput, pkgConfigProgram, needProgram, ConfiguredProgram) -import Distribution.Simple.Program.Run (getProgramInvocationOutputAndErrors, programInvocation) +import Distribution.Simple.Program.Run + (getProgramInvocationOutputAndErrors, programInvocation, getProgramInvocationLBSAndErrors) import Distribution.Simple.Utils (info) import Distribution.Types.PkgconfigVersion import Distribution.Types.PkgconfigVersionRange @@ -63,19 +70,53 @@ case mpkgConfig of Nothing -> noPkgConfig "Cannot find pkg-config program" Just (pkgConfig, _) -> do - pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"] - -- The output of @pkg-config --list-all@ also includes a description - -- for each package, which we do not need. - let pkgNames = map (takeWhile (not . isSpace)) pkgList - (pkgVersions, _errs, exitCode) <- + -- To prevent malformed Unicode in the descriptions from crashing cabal, + -- read without interpreting any encoding first. (#9608) + (listAllOutput, listAllErrs, listAllExitcode) <- + getProgramInvocationLBSAndErrors verbosity (programInvocation pkgConfig ["--list-all"]) + when (listAllExitcode /= ExitSuccess) $ + ioError (userError ("pkg-config --list-all failed: " ++ listAllErrs)) + let pkgList = LBS.split (fromIntegral (ord '\n')) listAllOutput + -- Now decode the package *names* to a String. The ones where decoding + -- failed end up in 'failedPkgNames'. + let (failedPkgNames, pkgNames) = + partitionEithers + -- Drop empty package names. This will handle empty lines + -- in pkg-config's output, including the spurious one + -- after the last newline (because of LBS.split). + . filter (either (const True) (not . null)) + -- Try decoding strictly; if it fails, put the lenient + -- decoding in a Left for later reporting. + . map (\bsname -> + let sbsname = LBS.toStrict bsname + in case T.decodeUtf8' sbsname of + Left _ -> Left (T.unpack (decodeUtf8LenientCompat sbsname)) + Right name -> Right (T.unpack name)) + -- The output of @pkg-config --list-all@ also includes a + -- description for each package, which we do not need. + -- We don't use Data.Char.isSpace because that would also + -- include 0xA0, the non-breaking space, which can occur + -- in multi-byte UTF-8 sequences. + . map (LBS.takeWhile (not . isAsciiSpace)) + $ pkgList + when (not (null failedPkgNames)) $ + info verbosity ("Some pkg-config packages have names containing invalid unicode: " ++ intercalate ", " failedPkgNames) + (outs, _errs, exitCode) <- getProgramInvocationOutputAndErrors verbosity (programInvocation pkgConfig ("--modversion" : pkgNames)) - case exitCode of - ExitSuccess -> (return . pkgConfigDbFromList . zip pkgNames) (lines pkgVersions) - -- if there's a single broken pc file the above fails, so we fall back into calling it individually - _ -> do - info verbosity ("call to pkg-config --modversion on all packages failed. Falling back to querying pkg-config individually on each package") - pkgConfigDbFromList . catMaybes <$> mapM (getIndividualVersion pkgConfig) pkgNames + let pkgVersions = lines outs + if exitCode == ExitSuccess && length pkgVersions == length pkgNames + then (return . pkgConfigDbFromList . zip pkgNames) pkgVersions + else + -- if there's a single broken pc file the above fails, so we fall back + -- into calling it individually + -- + -- Also some implementations of @pkg-config@ do not provide more than + -- one package version, so if the returned list is shorter than the + -- requested one, we fall back to querying one by one. + do + info verbosity ("call to pkg-config --modversion on all packages failed. Falling back to querying pkg-config individually on each package") + pkgConfigDbFromList . catMaybes <$> mapM (getIndividualVersion pkgConfig) pkgNames where -- For when pkg-config invocation fails (possibly because of a -- too long command line). @@ -96,6 +137,15 @@ return $ case exitCode of ExitSuccess -> Just (pkg, pkgVersion) _ -> Nothing + + isAsciiSpace :: Word8 -> Bool + isAsciiSpace c = c `elem` map (fromIntegral . ord) " \t" + + -- The decodeUtf8Lenient function is defined starting with text-2.0.1; this + -- function simply reimplements it. When the minimum supported GHC version + -- is >= 9.4, switch to decodeUtf8Lenient. + decodeUtf8LenientCompat :: ByteString -> T.Text + decodeUtf8LenientCompat = T.decodeUtf8With T.lenientDecode -- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs. pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb