diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -1,7 +1,7 @@ Cabal-Version: 2.2 Name: cabal-install -Version: 3.10.2.1 +Version: 3.10.3.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing @@ -17,8 +17,9 @@ Category: Distribution Build-type: Simple Extra-Source-Files: - README.md bash-completion/cabal +extra-doc-files: + README.md changelog source-repository head @@ -42,7 +43,9 @@ ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances -Wincomplete-uni-patterns -Wincomplete-record-updates if impl(ghc < 8.8) ghc-options: -Wnoncanonical-monadfail-instances - if impl(ghc >=8.10) + if impl(ghc >=9.0) + -- Warning: even though introduced with GHC 8.10, -Wunused-packages + -- gives false positives with GHC 8.10. ghc-options: -Wunused-packages common base-dep @@ -63,6 +66,10 @@ default-extensions: TypeOperators hs-source-dirs: src + autogen-modules: + Paths_cabal_install + other-modules: + Paths_cabal_install exposed-modules: -- this modules are moved from Cabal -- they are needed for as long until cabal-install moves to parsec parser @@ -101,6 +108,7 @@ Distribution.Client.Compat.Orphans Distribution.Client.Compat.Prelude Distribution.Client.Compat.Semaphore + Distribution.Client.Compat.Tar Distribution.Client.Config Distribution.Client.Configure Distribution.Client.Dependency @@ -205,16 +213,15 @@ async >= 2.0 && < 2.3, array >= 0.4 && < 0.6, base16-bytestring >= 0.1.1 && < 1.1.0.0, - base64-bytestring >= 1.0 && < 1.3, binary >= 0.7.3 && < 0.9, bytestring >= 0.10.6.0 && < 0.13, - containers >= 0.5.6.2 && < 0.7, + containers >= 0.5.6.2 && < 0.8, cryptohash-sha256 >= 0.11 && < 0.12, directory >= 1.3.7.0 && < 1.4, echo >= 0.1.3 && < 0.2, edit-distance >= 0.2.2 && < 0.3, exceptions >= 0.10.4 && < 0.11, - filepath >= 1.4.0.0 && < 1.5, + filepath >= 1.4.0.0 && < 1.6, hashable >= 1.0 && < 1.5, HTTP >= 4000.1.5 && < 4000.5, mtl >= 2.0 && < 2.4, @@ -223,9 +230,9 @@ process >= 1.2.3.0 && < 1.7, random >= 1.2 && < 1.3, stm >= 2.0 && < 2.6, - tar >= 0.5.0.3 && < 0.6, + tar >= 0.5.0.3 && < 0.7, time >= 1.5.0.1 && < 1.13, - zlib >= 0.5.3 && < 0.7, + zlib >= 0.5.3 && < 0.8, hackage-security >= 0.6.2.0 && < 0.7, text >= 1.2.3 && < 1.3 || >= 2.0 && < 2.2, parsec >= 3.1.13.0 && < 3.2, @@ -360,7 +367,7 @@ build-depends: cabal-install, containers, - tasty >= 1.2.3 && <1.5, + tasty >= 1.2.3 && <1.6, tasty-hunit >= 0.10 @@ -380,7 +387,7 @@ containers, directory, filepath, - tasty >= 1.2.3 && <1.5, + tasty >= 1.2.3 && <1.6, tasty-hunit >= 0.10, tagged @@ -416,7 +423,7 @@ network-uri >= 2.6.2.0 && <2.7, random, tagged, - tasty >= 1.2.3 && <1.5, + tasty >= 1.2.3 && <1.6, tasty-expected-failure, tasty-hunit >= 0.10, tasty-quickcheck, diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,8 @@ -*-change-log-*- +3.10.3.0 Hécate January 2024 + * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.10.3.0.md + 3.10.2.1 Hécate November 2023 * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.10.2.1.md diff --git a/src/Distribution/Client/CmdExec.hs b/src/Distribution/Client/CmdExec.hs --- a/src/Distribution/Client/CmdExec.hs +++ b/src/Distribution/Client/CmdExec.hs @@ -27,6 +27,10 @@ ( ConfigFlags(configVerbosity) , GlobalFlags ) +import Distribution.Client.ProjectConfig.Types + ( ProjectConfig (projectConfigShared) + , ProjectConfigShared (projectConfigProgPathExtra) + ) import Distribution.Client.ProjectFlags ( removeIgnoreProjectOption ) @@ -54,13 +58,13 @@ import Distribution.Simple.Command ( CommandUI(..) ) import Distribution.Simple.Program.Db - ( modifyProgramSearchPath + ( appendProgramSearchPath + , configuredPrograms , requireProgram , configuredPrograms ) import Distribution.Simple.Program.Find - ( ProgramSearchPathEntry(..) - ) + ( simpleProgram ) import Distribution.Simple.Program.Run ( programInvocation , runProgramInvocation @@ -69,7 +73,6 @@ ( programOverrideEnv , programDefaultArgs , programPath - , simpleProgram , ConfiguredProgram ) import Distribution.Simple.GHC @@ -80,12 +83,14 @@ ) import Distribution.Simple.Utils ( die' - , info , createDirectoryIfMissingVerbose , withTempDirectory , wrapText , notice ) +import Distribution.Utils.NubList + ( fromNubList + ) import Distribution.Verbosity ( normal ) @@ -147,13 +152,16 @@ mempty -- Some dependencies may have executables. Let's put those on the PATH. - extraPaths <- pathAdditions verbosity baseCtx buildCtx - let programDb = modifyProgramSearchPath - (map ProgramSearchPathDir extraPaths ++) - . pkgConfigCompilerProgs - . elaboratedShared - $ buildCtx + let extraPaths = pathAdditions baseCtx buildCtx + programDb <- + appendProgramSearchPath + verbosity + extraPaths + . pkgConfigCompilerProgs + . elaboratedShared + $ buildCtx + -- Now that we have the packages, set up the environment. We accomplish this -- by creating an environment file that selects the databases and packages we -- computed in the previous step, and setting an environment variable to @@ -235,15 +243,21 @@ buildStatus action envOverrides) -pathAdditions :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO [FilePath] -pathAdditions verbosity ProjectBaseContext{..}ProjectBuildContext{..} = do - info verbosity . unlines $ "Including the following directories in PATH:" - : paths - return paths +-- | Get paths to all dependency executables to be included in PATH. +pathAdditions :: ProjectBaseContext -> ProjectBuildContext -> [FilePath] +pathAdditions ProjectBaseContext{..} ProjectBuildContext{..} = + paths ++ cabalConfigPaths where - paths = S.toList - $ binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute + cabalConfigPaths = + fromNubList + . projectConfigProgPathExtra + . projectConfigShared + $ projectConfig + paths = + S.toList $ + binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute +-- | Get paths to all dependency executables to be included in PATH. binDirectories :: DistDirLayout -> ElaboratedSharedConfig diff --git a/src/Distribution/Client/CmdInstall.hs b/src/Distribution/Client/CmdInstall.hs --- a/src/Distribution/Client/CmdInstall.hs +++ b/src/Distribution/Client/CmdInstall.hs @@ -59,11 +59,9 @@ , projectConfigConfigFile ) import Distribution.Simple.Program.Db ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb - , modifyProgramSearchPath ) + , appendProgramSearchPath ) import Distribution.Simple.BuildPaths ( exeExtension ) -import Distribution.Simple.Program.Find - ( ProgramSearchPathEntry(..) ) import Distribution.Client.Config ( defaultInstallPath, loadConfig, SavedConfig(..) ) import qualified Distribution.Simple.PackageIndex as PI @@ -324,7 +322,8 @@ projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg, - projectConfigStoreDir + projectConfigStoreDir, + projectConfigProgPathExtra }, projectConfigLocalPackages = PackageConfig { packageConfigProgramPaths, @@ -337,14 +336,13 @@ hcPath = flagToMaybe projectConfigHcPath hcPkg = flagToMaybe projectConfigHcPkg + configProgDb <- appendProgramSearchPath verbosity ((fromNubList packageConfigProgramPathExtra) ++ (fromNubList projectConfigProgPathExtra)) defaultProgramDb + let -- ProgramDb with directly user specified paths preProgDb = - userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) - . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) - . modifyProgramSearchPath - (++ [ ProgramSearchPathDir dir - | dir <- fromNubList packageConfigProgramPathExtra ]) - $ defaultProgramDb + userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) + . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) + $ configProgDb -- progDb is a program database with compiler tools configured properly (compiler@Compiler { compilerId = diff --git a/src/Distribution/Client/CmdRun.hs b/src/Distribution/Client/CmdRun.hs --- a/src/Distribution/Client/CmdRun.hs +++ b/src/Distribution/Client/CmdRun.hs @@ -34,12 +34,14 @@ ( toList, foldPlanPackage ) import Distribution.Client.NixStyleOptions ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.ProjectConfig.Types import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage(..) - , ElaboratedInstallPlan, binDirectoryFor ) + , ElaboratedInstallPlan, binDirectoryFor + ) import Distribution.Client.ProjectPlanning.Types - ( dataDirsEnvironmentForPlan ) + ( dataDirsEnvironmentForPlan, elabExeDependencyPaths ) import Distribution.Client.ScriptUtils ( AcceptNoTargets(..), TargetContext(..) , updateContextAndWriteProjectFile, withContextAndSelectors @@ -52,6 +54,10 @@ ( CommandUI(..), usageAlternatives ) import Distribution.Simple.Flag ( fromFlagOrDefault ) +import Distribution.Simple.Program.Find + ( ProgramSearchPathEntry(..), defaultProgramSearchPath, + programSearchPathAsPATHVar, logExtraProgramSearchPath + ) import Distribution.Simple.Program.Run ( runProgramInvocation, ProgramInvocation(..), emptyProgramInvocation ) @@ -61,6 +67,8 @@ ( componentNameRaw ) import Distribution.Types.UnitId ( UnitId ) +import Distribution.Utils.NubList + ( fromNubList ) import Distribution.Types.UnqualComponentName ( UnqualComponentName, unUnqualComponentName ) @@ -69,6 +77,7 @@ import Data.List (group) import qualified Data.Set as Set + import System.Directory ( doesFileExist ) import System.FilePath @@ -230,6 +239,19 @@ let dryRun = buildSettingDryRun (buildSettings baseCtx) || buildSettingOnlyDownload (buildSettings baseCtx) + let extraPath = + elabExeDependencyPaths pkg + ++ ( fromNubList + . projectConfigProgPathExtra + . projectConfigShared + . projectConfig + $ baseCtx + ) + + logExtraProgramSearchPath verbosity extraPath + + progPath <- programSearchPathAsPATHVar (map ProgramSearchPathDir extraPath ++ defaultProgramSearchPath) + if dryRun then notice verbosity "Running of executable suppressed by flag(s)" else @@ -238,7 +260,8 @@ emptyProgramInvocation { progInvokePath = exePath, progInvokeArgs = args, - progInvokeEnv = dataDirsEnvironmentForPlan + progInvokeEnv = ("PATH", Just $ progPath) + : dataDirsEnvironmentForPlan (distDirLayout baseCtx) elaboratedPlan } diff --git a/src/Distribution/Client/Compat/Tar.hs b/src/Distribution/Client/Compat/Tar.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Compat/Tar.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{- FOURMOLU_DISABLE -} +module Distribution.Client.Compat.Tar + ( extractTarGzFile +#if MIN_VERSION_tar(0,6,0) + , Tar.Entry + , Tar.Entries + , Tar.GenEntries (..) + , Tar.GenEntryContent (..) + , Tar.entryContent +#else + , Tar.Entries (..) + , Tar.Entry (..) + , Tar.EntryContent (..) +#endif + ) where +{- FOURMOLU_ENABLE -} + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Check as Tar +#if MIN_VERSION_tar(0,6,0) +#else +import qualified Codec.Archive.Tar.Entry as Tar +#endif +import qualified Data.ByteString.Lazy as BS +import qualified Distribution.Client.GZipUtils as GZipUtils + +instance (Exception a, Exception b) => Exception (Either a b) where + toException (Left e) = toException e + toException (Right e) = toException e + + fromException e = + case fromException e of + Just e' -> Just (Left e') + Nothing -> case fromException e of + Just e' -> Just (Right e') + Nothing -> Nothing + +{- FOURMOLU_DISABLE -} +extractTarGzFile + :: FilePath + -- ^ Destination directory + -> FilePath + -- ^ Expected subdir (to check for tarbombs) + -> FilePath + -- ^ Tarball + -> IO () +extractTarGzFile dir expected tar = +#if MIN_VERSION_tar(0,6,0) + Tar.unpackAndCheck + ( \x -> + SomeException <$> Tar.checkEntryTarbomb expected x + <|> SomeException <$> Tar.checkEntrySecurity x + ) + dir +#else + Tar.unpack dir + . Tar.checkTarbomb expected +#endif + . Tar.read + . GZipUtils.maybeDecompress + =<< BS.readFile tar +{- FOURMOLU_ENABLE -} diff --git a/src/Distribution/Client/Config.hs b/src/Distribution/Client/Config.hs --- a/src/Distribution/Client/Config.hs +++ b/src/Distribution/Client/Config.hs @@ -1280,6 +1280,14 @@ , configConfigureArgs = splitMultiPath (configConfigureArgs scf) } + , savedGlobalFlags = + let sgf = savedGlobalFlags conf + in sgf { + globalProgPathExtra = + toNubList $ + splitMultiPath + (fromNubList $ globalProgPathExtra sgf) + } } parse = parseFields (configFieldDescriptions src diff --git a/src/Distribution/Client/Get.hs b/src/Distribution/Client/Get.hs --- a/src/Distribution/Client/Get.hs +++ b/src/Distribution/Client/Get.hs @@ -37,6 +37,8 @@ ( programName ) import Distribution.Types.SourceRepo (RepoKind (..)) import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy) +import Distribution.Utils.NubList + ( fromNubList ) import Distribution.Client.Setup ( GlobalFlags(..), GetFlags(..), RepoContext(..) ) @@ -54,6 +56,7 @@ import qualified Data.Map as Map import Control.Monad ( mapM_ ) + import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist ) import System.FilePath @@ -70,7 +73,7 @@ get verbosity _ _ _ [] = notice verbosity "No packages requested. Nothing to do." -get verbosity repoCtxt _ getFlags userTargets = do +get verbosity repoCtxt globalFlags getFlags userTargets = do let useSourceRepo = case getSourceRepository getFlags of NoFlag -> False _ -> True @@ -121,7 +124,7 @@ prefix = fromFlagOrDefault "" (getDestDir getFlags) clone :: [UnresolvedSourcePackage] -> IO () - clone = clonePackagesFromSourceRepo verbosity prefix kind + clone = clonePackagesFromSourceRepo verbosity prefix kind (fromNubList $ globalProgPathExtra globalFlags) . map (\pkg -> (packageId pkg, packageSourceRepos pkg)) where kind :: Maybe RepoKind @@ -278,18 +281,19 @@ clonePackagesFromSourceRepo :: Verbosity -> FilePath -- ^ destination dir prefix -> Maybe RepoKind -- ^ preferred 'RepoKind' + -> [FilePath] -- ^ Extra prog paths -> [(PackageId, [PD.SourceRepo])] -- ^ the packages and their -- available 'SourceRepo's -> IO () clonePackagesFromSourceRepo verbosity destDirPrefix - preferredRepoKind pkgrepos = do + preferredRepoKind progPaths pkgrepos = do -- Do a bunch of checks and collect the required info pkgrepos' <- traverse preCloneChecks pkgrepos -- Configure the VCS drivers for all the repository types we may need - vcss <- configureVCSs verbosity $ + vcss <- configureVCSs verbosity progPaths $ Map.fromList [ (vcsRepoType vcs, vcs) | (_, _, vcs, _) <- pkgrepos' ] diff --git a/src/Distribution/Client/HashValue.hs b/src/Distribution/Client/HashValue.hs --- a/src/Distribution/Client/HashValue.hs +++ b/src/Distribution/Client/HashValue.hs @@ -6,7 +6,6 @@ hashValue, truncateHash, showHashValue, - showHashValueBase64, readFileHashValue, hashFromTUF, ) where @@ -16,10 +15,9 @@ import qualified Hackage.Security.Client as Sec -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Base64 as Base64 -import qualified Data.ByteString.Char8 as BS +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import System.IO (IOMode (..), withBinaryFile) @@ -56,9 +54,6 @@ showHashValue :: HashValue -> String showHashValue (HashValue digest) = BS.unpack (Base16.encode digest) - -showHashValueBase64 :: HashValue -> String -showHashValueBase64 (HashValue digest) = BS.unpack (Base64.encode digest) -- | Hash the content of a file. Uses SHA256. -- diff --git a/src/Distribution/Client/HttpUtils.hs b/src/Distribution/Client/HttpUtils.hs --- a/src/Distribution/Client/HttpUtils.hs +++ b/src/Distribution/Client/HttpUtils.hs @@ -54,13 +54,12 @@ import Distribution.Simple.Program ( Program, simpleProgram, ConfiguredProgram, programPath , ProgramInvocation(..), programInvocation - , ProgramSearchPathEntry(..) , getProgramInvocationOutput ) import Distribution.Simple.Program.Db ( ProgramDb, emptyProgramDb, addKnownPrograms , configureAllKnownPrograms , requireProgram, lookupProgram - , modifyProgramSearchPath ) + , appendProgramSearchPath ) import Distribution.Simple.Program.Run ( getProgramInvocationOutputAndErrors ) import Numeric (showHex) @@ -336,7 +335,7 @@ case find (\(name',_,_,_) -> name' == name) supportedTransports of Just (_, mprog, _tls, mkTrans) -> do - let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb + baseProgDb <- appendProgramSearchPath verbosity extraPath emptyProgramDb progdb <- case mprog of Nothing -> return emptyProgramDb Just prog -> snd <$> requireProgram verbosity prog baseProgDb @@ -356,7 +355,7 @@ -- for all the transports except plain-http we need to try and find -- their external executable - let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb + baseProgDb <- appendProgramSearchPath verbosity extraPath emptyProgramDb progdb <- configureAllKnownPrograms verbosity $ addKnownPrograms [ prog | (_, Just prog, _, _) <- supportedTransports ] diff --git a/src/Distribution/Client/ProjectConfig.hs b/src/Distribution/Client/ProjectConfig.hs --- a/src/Distribution/Client/ProjectConfig.hs +++ b/src/Distribution/Client/ProjectConfig.hs @@ -1149,11 +1149,10 @@ [ ((rtype, rloc), [(repo, vcsRepoType vcs)]) | (repo, rloc, rtype, vcs) <- repos' ] - --TODO: pass progPathExtra on to 'configureVCS' - let _progPathExtra = fromNubList projectConfigProgPathExtra + let progPathExtra = fromNubList projectConfigProgPathExtra getConfiguredVCS <- delayInitSharedResources $ \repoType -> let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs in - configureVCS verbosity {-progPathExtra-} vcs + configureVCS verbosity progPathExtra vcs concat <$> sequenceA [ rerunIfChanged verbosity monitor repoGroup' $ do diff --git a/src/Distribution/Client/ProjectOrchestration.hs b/src/Distribution/Client/ProjectOrchestration.hs --- a/src/Distribution/Client/ProjectOrchestration.hs +++ b/src/Distribution/Client/ProjectOrchestration.hs @@ -190,7 +190,7 @@ deriving (Show, Eq) -- | This holds the context of a project prior to solving: the content of the --- @cabal.project@ and all the local package @.cabal@ files. +-- @cabal.project@, @cabal/config@ and all the local package @.cabal@ files. -- data ProjectBaseContext = ProjectBaseContext { distDirLayout :: DistDirLayout, diff --git a/src/Distribution/Client/ProjectPlanning.hs b/src/Distribution/Client/ProjectPlanning.hs --- a/src/Distribution/Client/ProjectPlanning.hs +++ b/src/Distribution/Client/ProjectPlanning.hs @@ -426,10 +426,12 @@ packageConfigProgramPathExtra) $ do liftIO $ info verbosity "Compiler settings changed, reconfiguring..." - result@(_, _, progdb') <- liftIO $ + progdb <- liftIO $ appendProgramSearchPath verbosity (fromNubList packageConfigProgramPathExtra) defaultProgramDb + let progdb' = userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) progdb + result@(_, _, progdb'') <- liftIO $ Cabal.configCompilerEx hcFlavor hcPath hcPkg - progdb verbosity + progdb' verbosity -- Note that we added the user-supplied program locations and args -- for /all/ programs, not just those for the compiler prog and @@ -437,21 +439,16 @@ -- the compiler will configure (and it does vary between compilers). -- We do know however that the compiler will only configure the -- programs it cares about, and those are the ones we monitor here. - monitorFiles (programsMonitorFiles progdb') + monitorFiles (programsMonitorFiles progdb'') return result where hcFlavor = flagToMaybe projectConfigHcFlavor hcPath = flagToMaybe projectConfigHcPath hcPkg = flagToMaybe projectConfigHcPkg - progdb = - userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) - . modifyProgramSearchPath - ([ ProgramSearchPathDir dir - | dir <- fromNubList packageConfigProgramPathExtra ] ++) - $ defaultProgramDb + -- | Return an up-to-date elaborated install plan. -- -- Two variants of the install plan are returned: with and without packages @@ -3397,7 +3394,10 @@ useDistPref = builddir, useLoggingHandle = Nothing, -- this gets set later useWorkingDir = Just srcdir, - useExtraPathEnv = elabExeDependencyPaths elab, + useExtraPathEnv = elabExeDependencyPaths elab ++ elabProgramPathExtra, + -- note that the above adds the extra-prog-path directly following the elaborated + -- dep paths, so that it overrides the normal path, but _not_ the elaborated extensions + -- for build-tools-depends. useExtraEnvOverrides = dataDirsEnvironmentForPlan distdir plan, useWin32CleanHack = False, --TODO: [required eventually] forceExternalSetupMethod = isParallelBuild, diff --git a/src/Distribution/Client/ScriptUtils.hs b/src/Distribution/Client/ScriptUtils.hs --- a/src/Distribution/Client/ScriptUtils.hs +++ b/src/Distribution/Client/ScriptUtils.hs @@ -27,7 +27,7 @@ import Distribution.Client.DistDirLayout ( DistDirLayout(..), DistDirParams(..) ) import Distribution.Client.HashValue - ( hashValue, showHashValueBase64 ) + ( hashValue, showHashValue, truncateHash ) import Distribution.Client.HttpUtils ( HttpTransport, configureTransport ) import Distribution.Client.NixStyleOptions @@ -131,17 +131,18 @@ -- repl to deal with the fact that the repl is relative to the working directory and not -- the project root. --- | Get the hash of a script's absolute path) +-- | Get the hash of a script's absolute path. -- -- Two hashes will be the same as long as the absolute paths -- are the same. getScriptHash :: FilePath -> IO String -getScriptHash script - -- Base64 is shorter than Base16, which helps avoid long path issues on windows - -- but it can contain /'s which aren't valid in file paths so replace them with - -- %'s. 26 chars / 130 bits is enough to practically avoid collisions. - = map (\c -> if c == '/' then '%' else c) . take 26 - . showHashValueBase64 . hashValue . fromString <$> canonicalizePath script +getScriptHash script = + -- Truncation here tries to help with long path issues on Windows. + showHashValue + . truncateHash 26 + . hashValue + . fromString + <$> canonicalizePath script -- | Get the directory for caching a script build. -- diff --git a/src/Distribution/Client/SetupWrapper.hs b/src/Distribution/Client/SetupWrapper.hs --- a/src/Distribution/Client/SetupWrapper.hs +++ b/src/Distribution/Client/SetupWrapper.hs @@ -29,6 +29,7 @@ import Distribution.CabalSpecVersion (cabalSpecMinimumLibraryVersion) import qualified Distribution.Make as Make import qualified Distribution.Simple as Simple + import Distribution.Version ( Version, mkVersion, versionNumbers, VersionRange, anyVersion , intersectVersionRanges, orLaterVersion @@ -59,9 +60,10 @@ ( ProgramDb, emptyProgramDb , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram , ghcjsProgram ) +import Distribution.Simple.Program.Db + ( appendProgramSearchPath ) import Distribution.Simple.Program.Find - ( programSearchPathAsPATHVar - , ProgramSearchPathEntry(ProgramSearchPathDir) ) + ( programSearchPathAsPATHVar ) import Distribution.Simple.Program.Run ( getEffectiveEnvironment ) import qualified Distribution.Simple.Program.Strip as Strip @@ -443,9 +445,9 @@ Nothing -> return () Just logHandle -> info verbosity $ "Redirecting build log to " ++ show logHandle - searchpath <- programSearchPathAsPATHVar - (map ProgramSearchPathDir (useExtraPathEnv options) ++ - getProgramSearchPath (useProgramDb options)) + progDb <- appendProgramSearchPath verbosity (useExtraPathEnv options) (useProgramDb options) + + searchpath <- programSearchPathAsPATHVar $ getProgramSearchPath progDb env <- getEffectiveEnvironment $ [ ("PATH", Just searchpath) , ("HASKELL_DIST_DIR", Just (useDistPref options)) diff --git a/src/Distribution/Client/Tar.hs b/src/Distribution/Client/Tar.hs --- a/src/Distribution/Client/Tar.hs +++ b/src/Distribution/Client/Tar.hs @@ -14,10 +14,11 @@ -- Reading, writing and manipulating \"@.tar@\" archive files. -- ----------------------------------------------------------------------------- -module Distribution.Client.Tar ( - -- * @tar.gz@ operations + +module Distribution.Client.Tar + ( -- * @tar.gz@ operations createTarGzFile, - extractTarGzFile, + TarComp.extractTarGzFile, -- * Other local utils buildTreeRefTypeCode, @@ -31,12 +32,11 @@ import Distribution.Client.Compat.Prelude import Prelude () -import qualified Data.ByteString.Lazy as BS -import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar -import qualified Codec.Archive.Tar.Check as Tar -import qualified Codec.Compression.GZip as GZip -import qualified Distribution.Client.GZipUtils as GZipUtils +import qualified Codec.Compression.GZip as GZip +import qualified Data.ByteString.Lazy as BS +import qualified Distribution.Client.Compat.Tar as TarComp -- for foldEntries... import Control.Exception (throw) @@ -51,26 +51,6 @@ -> IO () createTarGzFile tar base dir = BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base [dir] - -extractTarGzFile :: FilePath -- ^ Destination directory - -> FilePath -- ^ Expected subdir (to check for tarbombs) - -> FilePath -- ^ Tarball - -> IO () -extractTarGzFile dir expected tar = - Tar.unpack dir . Tar.checkTarbomb expected . Tar.read - . GZipUtils.maybeDecompress =<< BS.readFile tar - -instance (Exception a, Exception b) => Exception (Either a b) where - toException (Left e) = toException e - toException (Right e) = toException e - - fromException e = - case fromException e of - Just e' -> Just (Left e') - Nothing -> case fromException e of - Just e' -> Just (Right e') - Nothing -> Nothing - -- | Type code for the local build tree reference entry type. We don't use the -- symbolic link entry type because it allows only 100 ASCII characters for the diff --git a/src/Distribution/Client/VCS.hs b/src/Distribution/Client/VCS.hs --- a/src/Distribution/Client/VCS.hs +++ b/src/Distribution/Client/VCS.hs @@ -50,6 +50,8 @@ , simpleProgram, findProgramVersion , ProgramInvocation(..), programInvocation, runProgramInvocation, getProgramInvocationOutput , emptyProgramDb, requireProgram ) +import Distribution.Simple.Program.Db + ( appendProgramSearchPath ) import Distribution.Version ( mkVersion ) import qualified Distribution.PackageDescription as PD @@ -169,17 +171,20 @@ configureVCS :: Verbosity + -> [FilePath] -- ^ Extra prog paths -> VCS Program -> IO (VCS ConfiguredProgram) -configureVCS verbosity vcs@VCS{vcsProgram = prog} = - asVcsConfigured <$> requireProgram verbosity prog emptyProgramDb +configureVCS verbosity progPaths vcs@VCS{vcsProgram = prog} = do + progPath <- appendProgramSearchPath verbosity progPaths emptyProgramDb + asVcsConfigured <$> requireProgram verbosity prog progPath where asVcsConfigured (prog', _) = vcs { vcsProgram = prog' } configureVCSs :: Verbosity + -> [FilePath] -- ^ Extra prog paths -> Map RepoType (VCS Program) -> IO (Map RepoType (VCS ConfiguredProgram)) -configureVCSs verbosity = traverse (configureVCS verbosity) +configureVCSs verbosity progPaths = traverse (configureVCS verbosity progPaths) -- ------------------------------------------------------------ diff --git a/src/Distribution/Client/Version.hs b/src/Distribution/Client/Version.hs --- a/src/Distribution/Client/Version.hs +++ b/src/Distribution/Client/Version.hs @@ -6,11 +6,9 @@ import Distribution.Version --- This value determines the `cabal-install --version` output. --- --- It is used in several places throughout the project, including anonymous build reports, client configuration, --- and project planning output. Historically, this was a @Paths_*@ module, however, this conflicted with --- program coverage information generated by HPC, and hence was moved to be a standalone value. --- +import qualified Paths_cabal_install as PackageInfo + +-- | +-- This value determines the output of `cabal-install --version`. cabalInstallVersion :: Version -cabalInstallVersion = mkVersion [3,10,2,1] +cabalInstallVersion = mkVersion' PackageInfo.version diff --git a/tests/UnitTests/Distribution/Client/Get.hs b/tests/UnitTests/Distribution/Client/Get.hs --- a/tests/UnitTests/Distribution/Client/Get.hs +++ b/tests/UnitTests/Distribution/Client/Get.hs @@ -62,7 +62,7 @@ testNoRepos :: Assertion testNoRepos = do e <- assertException $ - clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos + clonePackagesFromSourceRepo verbosity "." Nothing [] pkgrepos e @?= ClonePackageNoSourceRepos pkgidfoo where pkgrepos = [(pkgidfoo, [])] @@ -71,7 +71,7 @@ testNoReposOfKind :: Assertion testNoReposOfKind = do e <- assertException $ - clonePackagesFromSourceRepo verbosity "." repokind pkgrepos + clonePackagesFromSourceRepo verbosity "." repokind [] pkgrepos e @?= ClonePackageNoSourceReposOfKind pkgidfoo repokind where pkgrepos = [(pkgidfoo, [repo])] @@ -82,7 +82,7 @@ testNoRepoType :: Assertion testNoRepoType = do e <- assertException $ - clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos + clonePackagesFromSourceRepo verbosity "." Nothing []pkgrepos e @?= ClonePackageNoRepoType pkgidfoo repo where pkgrepos = [(pkgidfoo, [repo])] @@ -92,7 +92,7 @@ testUnsupportedRepoType :: Assertion testUnsupportedRepoType = do e <- assertException $ - clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos + clonePackagesFromSourceRepo verbosity "." Nothing [] pkgrepos e @?= ClonePackageUnsupportedRepoType pkgidfoo repo' repotype where pkgrepos = [(pkgidfoo, [repo])] @@ -114,7 +114,7 @@ testNoRepoLocation :: Assertion testNoRepoLocation = do e <- assertException $ - clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos + clonePackagesFromSourceRepo verbosity "." Nothing [] pkgrepos e @?= ClonePackageNoRepoLocation pkgidfoo repo where pkgrepos = [(pkgidfoo, [repo])] @@ -133,7 +133,7 @@ e' <- test requestedRepoType (reverse pkgrepos) e' @?= ClonePackageNoRepoType pkgidfoo expectedRepo | let test rt rs = assertException $ - clonePackagesFromSourceRepo verbosity "." rt rs + clonePackagesFromSourceRepo verbosity "." rt [] rs , (requestedRepoType, expectedRepo) <- cases ] where @@ -154,14 +154,14 @@ let pkgdir = tmpdir "foo" createDirectory pkgdir e1 <- assertException $ - clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos + clonePackagesFromSourceRepo verbosity tmpdir Nothing [] pkgrepos e1 @?= ClonePackageDestinationExists pkgidfoo pkgdir True {- isdir -} removeDirectory pkgdir writeFile pkgdir "" e2 <- assertException $ - clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos + clonePackagesFromSourceRepo verbosity tmpdir Nothing [] pkgrepos e2 @?= ClonePackageDestinationExists pkgidfoo pkgdir False {- isfile -} where pkgrepos = [(pkgidfoo, [repo])] @@ -189,7 +189,7 @@ } pkgrepos = [(pkgidfoo, [repo])] e1 <- assertException $ - clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos + clonePackagesFromSourceRepo verbosity tmpdir Nothing [] pkgrepos e1 @?= ClonePackageFailedWithExitCode pkgidfoo repo' "git" (ExitFailure 128) @@ -200,7 +200,7 @@ repoType = Just (KnownRepoType Git), repoLocation = Just "https://github.com/haskell/zlib.git" } - clonePackagesFromSourceRepo verbosity tmpdir Nothing + clonePackagesFromSourceRepo verbosity tmpdir Nothing [] [(mkpkgid "zlib1", [repo1])] assertFileContains (tmpdir "zlib1/zlib.cabal") ["name:", "zlib"] @@ -208,7 +208,7 @@ repoType = Just (KnownRepoType Git), repoLocation = Just (tmpdir "zlib1") } - clonePackagesFromSourceRepo verbosity tmpdir Nothing + clonePackagesFromSourceRepo verbosity tmpdir Nothing [] [(mkpkgid "zlib2", [repo2])] assertFileContains (tmpdir "zlib2/zlib.cabal") ["name:", "zlib"] @@ -217,7 +217,7 @@ repoLocation = Just (tmpdir "zlib1"), repoTag = Just "0.5.0.0" } - clonePackagesFromSourceRepo verbosity tmpdir Nothing + clonePackagesFromSourceRepo verbosity tmpdir Nothing [] [(mkpkgid "zlib3", [repo3])] assertFileContains (tmpdir "zlib3/zlib.cabal") ["version:", "0.5.0.0"] where diff --git a/tests/UnitTests/Distribution/Client/Tar.hs b/tests/UnitTests/Distribution/Client/Tar.hs --- a/tests/UnitTests/Distribution/Client/Tar.hs +++ b/tests/UnitTests/Distribution/Client/Tar.hs @@ -2,17 +2,17 @@ tests ) where -import Distribution.Client.Tar ( filterEntries - , filterEntriesM - ) -import Codec.Archive.Tar ( Entries(..) - , foldEntries - ) -import Codec.Archive.Tar.Entry ( EntryContent(..) - , simpleEntry - , Entry(..) - , toTarPath - ) +import Codec.Archive.Tar + ( foldEntries + ) +import Codec.Archive.Tar.Entry + ( simpleEntry + , toTarPath + ) +import Distribution.Client.Tar + ( filterEntries + , filterEntriesM + ) import Test.Tasty import Test.Tasty.HUnit @@ -20,6 +20,8 @@ import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import Control.Monad.Writer.Lazy (runWriterT, tell) + +import Distribution.Client.Compat.Tar tests :: [TestTree] tests = [ testCase "filterEntries" filterTest diff --git a/tests/UnitTests/Distribution/Client/VCS.hs b/tests/UnitTests/Distribution/Client/VCS.hs --- a/tests/UnitTests/Distribution/Client/VCS.hs +++ b/tests/UnitTests/Distribution/Client/VCS.hs @@ -179,7 +179,7 @@ -> IO a testSetup vcs mkVCSTestDriver repoRecipe theTest = do -- test setup - vcs' <- configureVCS verbosity vcs + vcs' <- configureVCS verbosity [] vcs withTestDir verbosity "vcstest" $ \tmpdir -> do let srcRepoPath = tmpdir "src" submodulesPath = tmpdir "submodules"