diff --git a/Cabal/ChangeLog.md b/Cabal/ChangeLog.md index ae0ba7932fc..81cb7f3348a 100644 --- a/Cabal/ChangeLog.md +++ b/Cabal/ChangeLog.md @@ -77,6 +77,8 @@ `non`) and an optics to access the modules in a component of a `PackageDescription` by the `ComponentName`: `componentBuildInfo` and `componentModules` + * Linker `ld-options` are now passed to GHC as `-optl` options + ([#4925](https://github.com/haskell/cabal/pull/4925)). * Add `readGhcEnvironmentFile` to parse GHC environment files. * Drop support for GHC 7.4, since it is out of our support window (and has been for over a year!) diff --git a/Cabal/Distribution/Simple/GHC.hs b/Cabal/Distribution/Simple/GHC.hs index 67a5c2d4d5c..6d9f15e1c64 100644 --- a/Cabal/Distribution/Simple/GHC.hs +++ b/Cabal/Distribution/Simple/GHC.hs @@ -577,7 +577,11 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do linkerOpts = mempty { ghcOptLinkOptions = PD.ldOptions libBi ++ [ "-static" - | withFullyStaticExe lbi ], + | withFullyStaticExe lbi ] + -- Pass extra `ld-options` given + -- through to GHC's linker. + ++ maybe [] programOverrideArgs + (lookupProgram ldProgram (withPrograms lbi)), ghcOptLinkLibs = extraLibs libBi, ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, @@ -1274,7 +1278,11 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do linkerOpts = mempty { ghcOptLinkOptions = PD.ldOptions bnfo ++ [ "-static" - | withFullyStaticExe lbi ], + | withFullyStaticExe lbi ] + -- Pass extra `ld-options` given + -- through to GHC's linker. + ++ maybe [] programOverrideArgs + (lookupProgram ldProgram (withPrograms lbi)), ghcOptLinkLibs = extraLibs bnfo, ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo, ghcOptLinkFrameworks = toNubListR $ diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 59ae0ff36a6..fa81a1d4441 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -52,6 +52,7 @@ import Distribution.Deprecated.ViewAsFieldDescr import Distribution.Client.Types ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps + , HttpTransportFlags(..), emptyHttpTransportFlags ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) @@ -240,23 +241,24 @@ instance Semigroup SavedConfig where _ -> b' combinedSavedGlobalFlags = GlobalFlags { - globalVersion = combine globalVersion, - globalNumericVersion = combine globalNumericVersion, - globalConfigFile = combine globalConfigFile, - globalSandboxConfigFile = combine globalSandboxConfigFile, - globalConstraintsFile = combine globalConstraintsFile, - globalRemoteRepos = lastNonEmptyNL globalRemoteRepos, - globalCacheDir = combine globalCacheDir, - globalLocalRepos = lastNonEmptyNL globalLocalRepos, - globalLogsDir = combine globalLogsDir, - globalWorldFile = combine globalWorldFile, - globalRequireSandbox = combine globalRequireSandbox, - globalIgnoreSandbox = combine globalIgnoreSandbox, - globalIgnoreExpiry = combine globalIgnoreExpiry, - globalHttpTransport = combine globalHttpTransport, - globalNix = combine globalNix, - globalStoreDir = combine globalStoreDir, - globalProgPathExtra = lastNonEmptyNL globalProgPathExtra + globalVersion = combine globalVersion, + globalNumericVersion = combine globalNumericVersion, + globalConfigFile = combine globalConfigFile, + globalSandboxConfigFile = combine globalSandboxConfigFile, + globalConstraintsFile = combine globalConstraintsFile, + globalRemoteRepos = lastNonEmptyNL globalRemoteRepos, + globalCacheDir = combine globalCacheDir, + globalLocalRepos = lastNonEmptyNL globalLocalRepos, + globalLogsDir = combine globalLogsDir, + globalWorldFile = combine globalWorldFile, + globalRequireSandbox = combine globalRequireSandbox, + globalIgnoreSandbox = combine globalIgnoreSandbox, + globalIgnoreExpiry = combine globalIgnoreExpiry, + globalHttpTransport = combine globalHttpTransport, + globalHttpTransportFlags = combine globalHttpTransportFlags, + globalNix = combine globalNix, + globalStoreDir = combine globalStoreDir, + globalProgPathExtra = lastNonEmptyNL globalProgPathExtra } where combine = combine' savedGlobalFlags @@ -1087,9 +1089,12 @@ parseConfig src initial = \str -> do let init0 = savedInitFlags config user0 = savedUserInstallDirs config global0 = savedGlobalInstallDirs config - (remoteRepoSections0, haddockFlags, initFlags, user, global, paths, args) <- + + let http0 = globalHttpTransportFlags (savedGlobalFlags config) + + (http, remoteRepoSections0, haddockFlags, initFlags, user, global, paths, args) <- foldM parseSections - ([], savedHaddockFlags config, init0, user0, global0, [], []) + (http0, [], savedHaddockFlags config, init0, user0, global0, [], []) knownSections let remoteRepoSections = @@ -1099,6 +1104,7 @@ parseConfig src initial = \str -> do return . fixConfigMultilines $ config { savedGlobalFlags = (savedGlobalFlags config) { + globalHttpTransportFlags = http, globalRemoteRepos = toNubList remoteRepoSections, -- the global extra prog path comes from the configure flag prog path globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config) @@ -1121,6 +1127,7 @@ parseConfig src initial = \str -> do isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True + isKnownSection (ParseUtils.Section _ "http-transport" _ _) = True isKnownSection _ = False -- attempt to split fields that can represent lists of paths into actual lists @@ -1148,7 +1155,12 @@ parseConfig src initial = \str -> do parse = parseFields (configFieldDescriptions src ++ deprecatedFieldDescriptions) initial - parseSections (rs, h, i, u, g, p, a) + parseSections (_, rs, h, i, u, g, p, a) + (ParseUtils.Section _ "http-transport" name fs) = do + ts' <- parseFields httpTransportFields (emptyHttpTransportFlags name) fs + return (Flag ts', rs, h, i, u, g, p, a) + + parseSections (ts, rs, h, i, u, g, p, a) (ParseUtils.Section _ "repository" name fs) = do r' <- parseFields remoteRepoFields (emptyRemoteRepo name) fs when (remoteRepoKeyThreshold r' > length (remoteRepoRootKeys r')) $ @@ -1158,51 +1170,51 @@ parseConfig src initial = \str -> do && remoteRepoSecure r' /= Just True) $ warning $ "'root-keys' for repository " ++ show (remoteRepoName r') ++ " non-empty, but 'secure' not set to True." - return (r':rs, h, i, u, g, p, a) + return (ts, r':rs, h, i, u, g, p, a) - parseSections (rs, h, i, u, g, p, a) + parseSections (ts, rs, h, i, u, g, p, a) (ParseUtils.F lno "remote-repo" raw) = do let mr' = readRepo raw r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr' - return (r':rs, h, i, u, g, p, a) + return (ts, r':rs, h, i, u, g, p, a) - parseSections accum@(rs, h, i, u, g, p, a) + parseSections accum@(ts, rs, h, i, u, g, p, a) (ParseUtils.Section _ "haddock" name fs) | name == "" = do h' <- parseFields haddockFlagsFields h fs - return (rs, h', i, u, g, p, a) + return (ts, rs, h', i, u, g, p, a) | otherwise = do warning "The 'haddock' section should be unnamed" return accum - parseSections accum@(rs, h, i, u, g, p, a) + parseSections accum@(ts, rs, h, i, u, g, p, a) (ParseUtils.Section _ "init" name fs) | name == "" = do i' <- parseFields initFlagsFields i fs - return (rs, h, i', u, g, p, a) + return (ts, rs, h, i', u, g, p, a) | otherwise = do warning "The 'init' section should be unnamed" return accum - parseSections accum@(rs, h, i, u, g, p, a) + parseSections accum@(ts, rs, h, i, u, g, p, a) (ParseUtils.Section _ "install-dirs" name fs) | name' == "user" = do u' <- parseFields installDirsFields u fs - return (rs, h, i, u', g, p, a) + return (ts, rs, h, i, u', g, p, a) | name' == "global" = do g' <- parseFields installDirsFields g fs - return (rs, h, i, u, g', p, a) + return (ts, rs, h, i, u, g', p, a) | otherwise = do warning "The 'install-paths' section should be for 'user' or 'global'" return accum where name' = lowercase name - parseSections accum@(rs, h, i, u, g, p, a) + parseSections accum@(ts, rs, h, i, u, g, p, a) (ParseUtils.Section _ "program-locations" name fs) | name == "" = do p' <- parseFields withProgramsFields p fs - return (rs, h, i, u, g, p', a) + return (ts, rs, h, i, u, g, p', a) | otherwise = do warning "The 'program-locations' section should be unnamed" return accum - parseSections accum@(rs, h, i, u, g, p, a) + parseSections accum@(ts, rs, h, i, u, g, p, a) (ParseUtils.Section _ "program-default-options" name fs) | name == "" = do a' <- parseFields withProgramOptionsFields a fs - return (rs, h, i, u, g, p, a') + return (ts, rs, h, i, u, g, p, a') | otherwise = do warning "The 'program-default-options' section should be unnamed" return accum @@ -1257,6 +1269,21 @@ showConfigWithComments comment vals = Disp.render $ installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] installDirsFields = map viewAsFieldDescr installDirsOptions +ppHttpTransportSection :: HttpTransportFlags -> HttpTransportFlags -> Doc +ppHttpTransportSection def vals = ppSection "http-transport" (httpTransportFlagsName vals) + httpTransportFields (Just def) vals + +httpTransportFields :: [FieldDescr HttpTransportFlags] +httpTransportFields = + [ simpleField "netrc" + showUseNetrc (Just `fmap` Text.parse) + httpTransportFlagsUseNetrc (\v t -> t { httpTransportFlagsUseNetrc = v}) + ] + where + showUseNetrc Nothing = mempty -- default transport's setting + showUseNetrc (Just True) = text "True" -- user explicitly enabled it + showUseNetrc (Just False) = text "False" -- user explicitly disabled it + ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc ppRemoteRepoSection def vals = ppSection "repository" (remoteRepoName vals) remoteRepoFields (Just def) vals diff --git a/cabal-install/Distribution/Client/GlobalFlags.hs b/cabal-install/Distribution/Client/GlobalFlags.hs index dbaf07be930..31ec13ee62b 100644 --- a/cabal-install/Distribution/Client/GlobalFlags.hs +++ b/cabal-install/Distribution/Client/GlobalFlags.hs @@ -17,7 +17,8 @@ import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Client.Types - ( Repo(..), RemoteRepo(..) ) + ( Repo(..), RemoteRepo(..) + , HttpTransportFlags(..), emptyHttpTransportFlags ) import Distribution.Simple.Setup ( Flag(..), fromFlag, flagToMaybe ) import Distribution.Utils.NubList @@ -54,44 +55,46 @@ import qualified Distribution.Client.Security.DNS as Sec.DNS -- | Flags that apply at the top level, not to any sub-command. data GlobalFlags = GlobalFlags { - globalVersion :: Flag Bool, - globalNumericVersion :: Flag Bool, - globalConfigFile :: Flag FilePath, - globalSandboxConfigFile :: Flag FilePath, - globalConstraintsFile :: Flag FilePath, - globalRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. - globalCacheDir :: Flag FilePath, - globalLocalRepos :: NubList FilePath, - globalLogsDir :: Flag FilePath, - globalWorldFile :: Flag FilePath, - globalRequireSandbox :: Flag Bool, - globalIgnoreSandbox :: Flag Bool, - globalIgnoreExpiry :: Flag Bool, -- ^ Ignore security expiry dates - globalHttpTransport :: Flag String, - globalNix :: Flag Bool, -- ^ Integrate with Nix - globalStoreDir :: Flag FilePath, - globalProgPathExtra :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports) + globalVersion :: Flag Bool, + globalNumericVersion :: Flag Bool, + globalConfigFile :: Flag FilePath, + globalSandboxConfigFile :: Flag FilePath, + globalConstraintsFile :: Flag FilePath, + globalRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. + globalCacheDir :: Flag FilePath, + globalLocalRepos :: NubList FilePath, + globalLogsDir :: Flag FilePath, + globalWorldFile :: Flag FilePath, + globalRequireSandbox :: Flag Bool, + globalIgnoreSandbox :: Flag Bool, + globalIgnoreExpiry :: Flag Bool, -- ^ Ignore security expiry dates + globalHttpTransport :: Flag String, + globalHttpTransportFlags :: Flag HttpTransportFlags, + globalNix :: Flag Bool, -- ^ Integrate with Nix + globalStoreDir :: Flag FilePath, + globalProgPathExtra :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports) } deriving Generic defaultGlobalFlags :: GlobalFlags defaultGlobalFlags = GlobalFlags { - globalVersion = Flag False, - globalNumericVersion = Flag False, - globalConfigFile = mempty, - globalSandboxConfigFile = mempty, - globalConstraintsFile = mempty, - globalRemoteRepos = mempty, - globalCacheDir = mempty, - globalLocalRepos = mempty, - globalLogsDir = mempty, - globalWorldFile = mempty, - globalRequireSandbox = Flag False, - globalIgnoreSandbox = Flag False, - globalIgnoreExpiry = Flag False, - globalHttpTransport = mempty, - globalNix = Flag False, - globalStoreDir = mempty, - globalProgPathExtra = mempty + globalVersion = Flag False, + globalNumericVersion = Flag False, + globalConfigFile = mempty, + globalSandboxConfigFile = mempty, + globalConstraintsFile = mempty, + globalRemoteRepos = mempty, + globalCacheDir = mempty, + globalLocalRepos = mempty, + globalLogsDir = mempty, + globalWorldFile = mempty, + globalRequireSandbox = Flag False, + globalIgnoreSandbox = Flag False, + globalIgnoreExpiry = Flag False, + globalHttpTransport = mempty, + globalHttpTransportFlags = mempty, + globalNix = Flag False, + globalStoreDir = mempty, + globalProgPathExtra = mempty } instance Monoid GlobalFlags where @@ -141,20 +144,23 @@ withRepoContext :: Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a withRepoContext verbosity globalFlags = withRepoContext' verbosity - (fromNubList (globalRemoteRepos globalFlags)) - (fromNubList (globalLocalRepos globalFlags)) - (fromFlag (globalCacheDir globalFlags)) - (flagToMaybe (globalHttpTransport globalFlags)) - (flagToMaybe (globalIgnoreExpiry globalFlags)) - (fromNubList (globalProgPathExtra globalFlags)) + (fromNubList (globalRemoteRepos globalFlags)) + (fromNubList (globalLocalRepos globalFlags)) + (fromFlag (globalCacheDir globalFlags)) + (flagToMaybe (globalHttpTransport globalFlags)) + (flagToMaybe (globalHttpTransportFlags globalFlags)) + (flagToMaybe (globalIgnoreExpiry globalFlags)) + (fromNubList (globalProgPathExtra globalFlags)) withRepoContext' :: Verbosity -> [RemoteRepo] -> [FilePath] - -> FilePath -> Maybe String -> Maybe Bool + -> FilePath -> Maybe String -> Maybe HttpTransportFlags -> Maybe Bool -> [FilePath] -> (RepoContext -> IO a) -> IO a withRepoContext' verbosity remoteRepos localRepos - sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do + sharedCacheDir + httpTransport httpTransportFlags + ignoreExpiry extraPaths = \callback -> do transportRef <- newMVar Nothing let httpLib = Sec.HTTP.transportAdapter verbosity @@ -182,7 +188,13 @@ withRepoContext' verbosity remoteRepos localRepos modifyMVar transportRef $ \mTransport -> do transport <- case mTransport of Just tr -> return tr - Nothing -> configureTransport verbosity extraPaths httpTransport + Nothing -> do + httpFlags <- case (httpTransport, httpTransportFlags) of + (Just _, Just _) -> + throwIO $ userError "http-transport: conflicting stanzas: 'http-transport' is defined twice" + (Just t, _) -> return $ Just (emptyHttpTransportFlags t) + (_, t) -> return t + configureTransport verbosity extraPaths httpFlags return (Just transport, transport) withSecureRepo :: Map Repo SecureRepo diff --git a/cabal-install/Distribution/Client/HttpUtils.hs b/cabal-install/Distribution/Client/HttpUtils.hs index 1fd8ae86b2b..de19f317edc 100644 --- a/cabal-install/Distribution/Client/HttpUtils.hs +++ b/cabal-install/Distribution/Client/HttpUtils.hs @@ -43,7 +43,7 @@ import Distribution.Simple.Utils import Distribution.Client.Utils ( withTempFileName ) import Distribution.Client.Types - ( RemoteRepo(..) ) + ( RemoteRepo(..), HttpTransportFlags(..), emptyHttpTransportFlags ) import Distribution.System ( buildOS, buildArch ) import qualified System.FilePath.Posix as FilePath.Posix @@ -248,27 +248,28 @@ noPostYet :: Verbosity -> URI -> String -> Maybe (String, String) noPostYet verbosity _ _ _ = die' verbosity "Posting (for report upload) is not implemented yet" supportedTransports :: [(String, Maybe Program, Bool, - ProgramDb -> Maybe HttpTransport)] + ProgramDb -> HttpTransportFlags -> Maybe HttpTransport)] supportedTransports = [ let prog = simpleProgram "curl" in ( "curl", Just prog, True - , \db -> curlTransport <$> lookupProgram prog db ) + , \db httpTransportFlag -> curlTransport httpTransportFlag <$> lookupProgram prog db) , let prog = simpleProgram "wget" in ( "wget", Just prog, True - , \db -> wgetTransport <$> lookupProgram prog db ) + , \db httpTransportFlag -> wgetTransport httpTransportFlag <$> lookupProgram prog db ) , let prog = simpleProgram "powershell" in ( "powershell", Just prog, True - , \db -> powershellTransport <$> lookupProgram prog db ) + , \db _ -> powershellTransport <$> lookupProgram prog db ) , ( "plain-http", Nothing, False - , \_ -> Just plainHttpTransport ) + , \_ _ -> Just plainHttpTransport ) ] -configureTransport :: Verbosity -> [FilePath] -> Maybe String -> IO HttpTransport +configureTransport :: Verbosity -> [FilePath] -> Maybe HttpTransportFlags -> IO HttpTransport -configureTransport verbosity extraPath (Just name) = +configureTransport verbosity extraPath (Just httpTransportFlags) = + let name = httpTransportFlagsName httpTransportFlags in -- the user specifically selected a transport by name so we'll try and -- configure that one @@ -281,7 +282,7 @@ configureTransport verbosity extraPath (Just name) = Just prog -> snd <$> requireProgram verbosity prog baseProgDb -- ^^ if it fails, it'll fail here - let Just transport = mkTrans progdb + let Just transport = mkTrans progdb httpTransportFlags return transport { transportManuallySelected = True } Nothing -> die' verbosity $ "Unknown HTTP transport specified: " ++ name @@ -304,7 +305,7 @@ configureTransport verbosity extraPath Nothing = do let availableTransports = [ (name, transport) | (name, _, _, mkTrans) <- supportedTransports - , transport <- maybeToList (mkTrans progdb) ] + , transport <- maybeToList (mkTrans progdb (emptyHttpTransportFlags name)) ] -- there's always one because the plain one is last and never fails let (name, transport) = head availableTransports debug verbosity $ "Selected http transport implementation: " ++ name @@ -316,8 +317,8 @@ configureTransport verbosity extraPath Nothing = do -- The HttpTransports based on external programs -- -curlTransport :: ConfiguredProgram -> HttpTransport -curlTransport prog = +curlTransport :: HttpTransportFlags -> ConfiguredProgram -> HttpTransport +curlTransport httpTransportFlags prog = HttpTransport gethttp posthttp posthttpfile puthttpfile True False where gethttp verbosity uri etag destPath reqHeaders = do @@ -331,6 +332,7 @@ curlTransport prog = , "--user-agent", userAgent , "--silent", "--show-error" , "--dump-header", tmpFile ] + ++ netrcFlags ++ concat [ ["--header", "If-None-Match: " ++ t] | t <- maybeToList etag ] @@ -366,6 +368,7 @@ curlTransport prog = , "--header", "Accept: text/plain" , "--location" ] + ++ netrcFlags resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth (programInvocation prog args) (code, err, _etag) <- parseResponse verbosity uri resp "" @@ -380,6 +383,7 @@ curlTransport prog = , "--location" , "--header", "Accept: text/plain" ] + ++ netrcFlags ++ concat [ ["--header", show name ++ ": " ++ value] | Header name value <- headers ] @@ -388,6 +392,10 @@ curlTransport prog = (code, err, _etag) <- parseResponse verbosity uri resp "" return (code, err) + netrcFlags = case httpTransportFlagsUseNetrc httpTransportFlags of + Just True -> ["--netrc"] + _ -> [] + -- on success these curl invocations produces an output like "200" -- and on failure it has the server error response first parseResponse :: Verbosity -> URI -> String -> String -> IO (Int, String, Maybe ETag) @@ -413,8 +421,8 @@ curlTransport prog = _ -> statusParseFail verbosity uri resp -wgetTransport :: ConfiguredProgram -> HttpTransport -wgetTransport prog = +wgetTransport :: HttpTransportFlags -> ConfiguredProgram -> HttpTransport +wgetTransport httpTransportFlags prog = HttpTransport gethttp posthttp posthttpfile puthttpfile True False where gethttp verbosity uri etag destPath reqHeaders = do @@ -503,10 +511,15 @@ wgetTransport prog = a = fromMaybe (URIAuth "" "" "") (uriAuthority uri) runWGet verbosity uri args = do + let netrcFlags = case httpTransportFlagsUseNetrc httpTransportFlags of + Just False -> ["--no-netrc"] + _ -> [] + -- We pass the URI via STDIN because it contains the users' credentials -- and sensitive data should not be passed via command line arguments. let - invocation = (programInvocation prog ("--input-file=-" : args)) + args' = netrcFlags ++ args + invocation = (programInvocation prog ("--input-file=-" : args')) { progInvokeInput = Just (uriToString id uri "") } diff --git a/cabal-install/Distribution/Client/ProjectConfig.hs b/cabal-install/Distribution/Client/ProjectConfig.hs index 23e3cd987e7..eaefb57667b 100644 --- a/cabal-install/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/Distribution/Client/ProjectConfig.hs @@ -185,6 +185,7 @@ projectConfigWithBuilderRepoContext verbosity BuildTimeSettings{..} = buildSettingLocalRepos buildSettingCacheDir buildSettingHttpTransport + buildSettingHttpTransportFlags (Just buildSettingIgnoreExpiry) buildSettingProgPathExtra @@ -210,6 +211,7 @@ projectConfigWithSolverRepoContext verbosity "projectConfigWithSolverRepoContext: projectConfigCacheDir") projectConfigCacheDir) (flagToMaybe projectConfigHttpTransport) + (flagToMaybe projectConfigHttpTransportFlags) (flagToMaybe projectConfigIgnoreExpiry) (fromNubList projectConfigProgPathExtra) @@ -314,6 +316,7 @@ resolveBuildTimeSettings verbosity buildSettingLocalRepos = fromNubList projectConfigLocalRepos buildSettingCacheDir = fromFlag projectConfigCacheDir buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport + buildSettingHttpTransportFlags = flagToMaybe projectConfigHttpTransportFlags buildSettingIgnoreExpiry = fromFlag projectConfigIgnoreExpiry buildSettingReportPlanningFailure = fromFlag projectConfigReportPlanningFailure @@ -951,6 +954,9 @@ mplusMaybeT ma mb = do Nothing -> mb Just x -> return (Just x) +lookupTransportFlags :: Maybe String -> Maybe HttpTransportFlags -> Maybe HttpTransportFlags +lookupTransportFlags (Just httpTransport) fs = find ((== httpTransport) . httpTransportFlagsName) fs +lookupTransportFlags Nothing _ = Nothing ------------------------------------------------- -- Fetching and reading packages in the project @@ -988,7 +994,8 @@ fetchAndReadSourcePackages verbosity distDirLayout pkgsRemoteTarball <- do getTransport <- delayInitSharedResource $ configureTransport verbosity progPathExtra - preferredHttpTransport + ( lookupTransportFlags preferredHttpTransport + (flagToMaybe (projectConfigHttpTransportFlags projectConfigBuildOnly))) sequence [ fetchAndReadSourcePackageRemoteTarball verbosity distDirLayout getTransport uri diff --git a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs index 1904d51be9d..ffc421e13db 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs @@ -473,6 +473,7 @@ convertLegacyBuildOnlyFlags globalFlags configFlags globalLogsDir = projectConfigLogsDir, globalWorldFile = _, globalHttpTransport = projectConfigHttpTransport, + globalHttpTransportFlags = projectConfigHttpTransportFlags, globalIgnoreExpiry = projectConfigIgnoreExpiry } = globalFlags @@ -546,23 +547,24 @@ convertToLegacySharedConfig } where globalFlags = GlobalFlags { - globalVersion = mempty, - globalNumericVersion = mempty, - globalConfigFile = projectConfigConfigFile, - globalSandboxConfigFile = mempty, - globalConstraintsFile = mempty, - globalRemoteRepos = projectConfigRemoteRepos, - globalCacheDir = projectConfigCacheDir, - globalLocalRepos = projectConfigLocalRepos, - globalLogsDir = projectConfigLogsDir, - globalWorldFile = mempty, - globalRequireSandbox = mempty, - globalIgnoreSandbox = mempty, - globalIgnoreExpiry = projectConfigIgnoreExpiry, - globalHttpTransport = projectConfigHttpTransport, - globalNix = mempty, - globalStoreDir = projectConfigStoreDir, - globalProgPathExtra = projectConfigProgPathExtra + globalVersion = mempty, + globalNumericVersion = mempty, + globalConfigFile = projectConfigConfigFile, + globalSandboxConfigFile = mempty, + globalConstraintsFile = mempty, + globalRemoteRepos = projectConfigRemoteRepos, + globalCacheDir = projectConfigCacheDir, + globalLocalRepos = projectConfigLocalRepos, + globalLogsDir = projectConfigLogsDir, + globalWorldFile = mempty, + globalRequireSandbox = mempty, + globalIgnoreSandbox = mempty, + globalIgnoreExpiry = projectConfigIgnoreExpiry, + globalHttpTransport = projectConfigHttpTransport, + globalHttpTransportFlags = mempty, + globalNix = mempty, + globalStoreDir = projectConfigStoreDir, + globalProgPathExtra = projectConfigProgPathExtra } configFlags = mempty { diff --git a/cabal-install/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/Distribution/Client/ProjectConfig/Types.hs index 7472102c9b3..365ada6a186 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Types.hs @@ -22,7 +22,8 @@ module Distribution.Client.ProjectConfig.Types ( import Distribution.Client.Types ( RemoteRepo, AllowNewer(..), AllowOlder(..) - , WriteGhcEnvironmentFilesPolicy ) + , WriteGhcEnvironmentFilesPolicy + , HttpTransportFlags(..) ) import Distribution.Client.Dependency.Types ( PreSolver ) import Distribution.Client.Targets @@ -150,6 +151,7 @@ data ProjectConfigBuildOnly projectConfigOfflineMode :: Flag Bool, projectConfigKeepTempFiles :: Flag Bool, projectConfigHttpTransport :: Flag String, + projectConfigHttpTransportFlags :: Flag HttpTransportFlags, projectConfigIgnoreExpiry :: Flag Bool, projectConfigCacheDir :: Flag FilePath, projectConfigLogsDir :: Flag FilePath, @@ -439,6 +441,7 @@ data BuildTimeSettings buildSettingLocalRepos :: [FilePath], buildSettingCacheDir :: FilePath, buildSettingHttpTransport :: Maybe String, + buildSettingHttpTransportFlags :: Maybe HttpTransportFlags, buildSettingIgnoreExpiry :: Bool, buildSettingProgPathExtra :: [FilePath] } diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index eb5330d3d16..1ac7f0731c8 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -408,6 +408,7 @@ globalCommand commands = CommandUI { "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')" globalHttpTransport (\v flags -> flags { globalHttpTransport = v }) (reqArgFlag "HttpTransport") + ,option [] ["nix"] "Nix integration: run commands through nix-shell if a 'shell.nix' file exists" globalNix (\v flags -> flags { globalNix = v }) @@ -2954,6 +2955,12 @@ parseRepo = do remoteRepoShouldTryHttps = False } +-- parseHttpTransportFlags :: Parse.ReadP r HttpTransportFlags +-- parseHttpTransportFlags = do +-- name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.") +-- _ <- Parse.char ':' + + -- ------------------------------------------------------------ -- * Helpers for Documentation -- ------------------------------------------------------------ diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs index 8ae60f55312..147d523c427 100644 --- a/cabal-install/Distribution/Client/Types.hs +++ b/cabal-install/Distribution/Client/Types.hs @@ -303,6 +303,25 @@ instance Binary URIAuth where put (URIAuth a b c) = do put a; put b; put c get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c) +data HttpTransportFlags = + HttpTransportFlags { + httpTransportFlagsName :: String, + + -- | Enable netrc? + -- + -- 'Nothing' here represents "whatever default is"; + -- this is important for backwards compatibility + -- because different transports have different defaults + -- (wget uses netrc by default, but curl does not, etc.) + httpTransportFlagsUseNetrc :: Maybe Bool + } + deriving (Show, Eq, Ord, Generic) + +instance Binary HttpTransportFlags + +emptyHttpTransportFlags :: String -> HttpTransportFlags +emptyHttpTransportFlags name = HttpTransportFlags name Nothing + data RemoteRepo = RemoteRepo { remoteRepoName :: String, diff --git a/cabal-install/Distribution/Deprecated/ParseUtils.hs b/cabal-install/Distribution/Deprecated/ParseUtils.hs index cda1e5bde7c..7800b1f879a 100644 --- a/cabal-install/Distribution/Deprecated/ParseUtils.hs +++ b/cabal-install/Distribution/Deprecated/ParseUtils.hs @@ -721,4 +721,4 @@ parseFlagAssignment = mkFlagAssignment <$> ------------------------------------------------------------------------------- showTestedWith :: (CompilerFlavor, VersionRange) -> Doc -showTestedWith = pretty . pack' TestedWith \ No newline at end of file +showTestedWith = pretty . pack' TestedWith diff --git a/cabal-install/changelog b/cabal-install/changelog index 12c115eab12..16d62833a48 100644 --- a/cabal-install/changelog +++ b/cabal-install/changelog @@ -39,6 +39,7 @@ * Add --test-wrapper that allows a prebuild script to set the test environment. * Add filterTestFlags: filter test-wrapper for Cabal < 3.0.0. * Cabal now only builds the minimum of a package for `v2-install` (#5754, #6091) + * Cabal uses `~/.netrc` when using the curlnetrc transport method. 2.4.1.0 Mikhail Glushenkov November 2018 * Add message to alert user to potential package casing errors. (#5635)