From 7e0a7b85d243e8cc55bc43215f50a06a88d65a24 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Niklas=20Hamb=C3=BCchen?= Date: Sat, 21 Jul 2018 00:31:59 +0200 Subject: [PATCH 01/13] Pass `ld-options` through to GHC. Fixes #4925 --- Cabal/Distribution/Simple/GHC.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) 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 $ From 26f5b34efc946e04a4a02c8ffef1c62042a521bc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Niklas=20Hamb=C3=BCchen?= Date: Sat, 21 Jul 2018 01:08:36 +0200 Subject: [PATCH 02/13] Changelog: Add entry for `ld-options` being passed to ghc --- Cabal/ChangeLog.md | 2 ++ 1 file changed, 2 insertions(+) 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!) From 08e16acc11d39db6de7fa70aed287266927de4bf Mon Sep 17 00:00:00 2001 From: alexeyraga Date: Fri, 9 Aug 2019 10:29:37 +1000 Subject: [PATCH 03/13] Add http-transport-flags --- cabal-install/Distribution/Client/Config.hs | 52 +++++++++----- .../Distribution/Client/GlobalFlags.hs | 72 ++++++++++--------- .../Client/ProjectConfig/Legacy.hs | 1 + cabal-install/Distribution/Client/Setup.hs | 14 ++++ cabal-install/Distribution/Client/Types.hs | 16 +++++ .../Distribution/Deprecated/ParseUtils.hs | 2 +- 6 files changed, 104 insertions(+), 53 deletions(-) diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 59ae0ff36a6..ee2ea5f1707 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(..) ) 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 = lastNonEmptyNL globalHttpTransportFlags, + globalNix = combine globalNix, + globalStoreDir = combine globalStoreDir, + globalProgPathExtra = lastNonEmptyNL globalProgPathExtra } where combine = combine' savedGlobalFlags @@ -1121,6 +1123,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 @@ -1257,6 +1260,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..a86721b915d 100644 --- a/cabal-install/Distribution/Client/GlobalFlags.hs +++ b/cabal-install/Distribution/Client/GlobalFlags.hs @@ -17,7 +17,7 @@ import Prelude () import Distribution.Client.Compat.Prelude import Distribution.Client.Types - ( Repo(..), RemoteRepo(..) ) + ( Repo(..), RemoteRepo(..), HttpTransportFlags(..) ) import Distribution.Simple.Setup ( Flag(..), fromFlag, flagToMaybe ) import Distribution.Utils.NubList @@ -54,44 +54,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 :: NubList 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 diff --git a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs index 1904d51be9d..4ace7a84c6b 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs @@ -560,6 +560,7 @@ convertToLegacySharedConfig globalIgnoreSandbox = mempty, globalIgnoreExpiry = projectConfigIgnoreExpiry, globalHttpTransport = projectConfigHttpTransport, + globalHttpTransportArgs = mempty, globalNix = mempty, globalStoreDir = projectConfigStoreDir, globalProgPathExtra = projectConfigProgPathExtra diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index eb5330d3d16..1a8c8271e51 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -408,6 +408,14 @@ 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 [] ["http-transport-config"] + "Set extra arguments for an http transport that is configured with 'http-transport' option." + globalHttpTransportFlags (\v flags -> flags { globalHttpTransportFlags = v }) + -- TODO: FIX IT + undefined + -- (reqArg' "ARGS" (\x -> toNubList []) fromNubList) + ,option [] ["nix"] "Nix integration: run commands through nix-shell if a 'shell.nix' file exists" globalNix (\v flags -> flags { globalNix = v }) @@ -2954,6 +2962,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..0cd47913655 100644 --- a/cabal-install/Distribution/Client/Types.hs +++ b/cabal-install/Distribution/Client/Types.hs @@ -303,6 +303,22 @@ 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 + 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 From e69106b0f3240aa4fc80d0aa27249f379b3c56f7 Mon Sep 17 00:00:00 2001 From: alexeyraga Date: Fri, 9 Aug 2019 10:55:51 +1000 Subject: [PATCH 04/13] Fix legacy --- .../Client/ProjectConfig/Legacy.hs | 36 +++++++++---------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs index 4ace7a84c6b..e172bcabcdd 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs @@ -546,24 +546,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, - globalHttpTransportArgs = mempty, - 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 { From f4e9476016b2d507c7b89bf0483fd18944b30396 Mon Sep 17 00:00:00 2001 From: alexeyraga Date: Fri, 9 Aug 2019 12:05:39 +1000 Subject: [PATCH 05/13] Wire up HttpTransportFlags --- cabal-install/Distribution/Client/Config.hs | 46 ++++++++++++--------- cabal-install/Distribution/Client/Types.hs | 3 ++ 2 files changed, 30 insertions(+), 19 deletions(-) diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index ee2ea5f1707..22fb92adbe4 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -52,7 +52,7 @@ import Distribution.Deprecated.ViewAsFieldDescr import Distribution.Client.Types ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps - , HttpTransportFlags(..) + , HttpTransportFlags(..), emptyHttpTransportFlags ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) @@ -1089,11 +1089,13 @@ parseConfig src initial = \str -> do let init0 = savedInitFlags config user0 = savedUserInstallDirs config global0 = savedGlobalInstallDirs config - (remoteRepoSections0, haddockFlags, initFlags, user, global, paths, args) <- + (httpTransportSections0, remoteRepoSections0, haddockFlags, initFlags, user, global, paths, args) <- foldM parseSections - ([], savedHaddockFlags config, init0, user0, global0, [], []) + ([], [], savedHaddockFlags config, init0, user0, global0, [], []) knownSections + let httpTransportSections = nubBy ((==) `on` httpTransportFlagsName) httpTransportSections0 + let remoteRepoSections = reverse . nubBy ((==) `on` remoteRepoName) @@ -1101,6 +1103,7 @@ parseConfig src initial = \str -> do return . fixConfigMultilines $ config { savedGlobalFlags = (savedGlobalFlags config) { + globalHttpTransportFlags = toNubList httpTransportSections, globalRemoteRepos = toNubList remoteRepoSections, -- the global extra prog path comes from the configure flag prog path globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config) @@ -1123,7 +1126,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 (ParseUtils.Section _ "http-transport-flags" _ _) = True isKnownSection _ = False -- attempt to split fields that can represent lists of paths into actual lists @@ -1151,7 +1154,12 @@ parseConfig src initial = \str -> do parse = parseFields (configFieldDescriptions src ++ deprecatedFieldDescriptions) initial - parseSections (rs, h, i, u, g, p, a) + parseSections (ts, rs, h, i, u, g, p, a) + (ParseUtils.Section _ "http-transport-config" name fs) = do + t' <- parseFields httpTransportFields (emptyHttpTransportFlags name) fs + return (t':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')) $ @@ -1161,51 +1169,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 diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs index 0cd47913655..147d523c427 100644 --- a/cabal-install/Distribution/Client/Types.hs +++ b/cabal-install/Distribution/Client/Types.hs @@ -319,6 +319,9 @@ data HttpTransportFlags = instance Binary HttpTransportFlags +emptyHttpTransportFlags :: String -> HttpTransportFlags +emptyHttpTransportFlags name = HttpTransportFlags name Nothing + data RemoteRepo = RemoteRepo { remoteRepoName :: String, From 49f278b8de10c5d5e7d624df16f933a3b3149374 Mon Sep 17 00:00:00 2001 From: alexeyraga Date: Fri, 9 Aug 2019 14:02:21 +1000 Subject: [PATCH 06/13] Delete unfinished options --- cabal-install/Distribution/Client/Setup.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index 1a8c8271e51..1ac7f0731c8 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -409,13 +409,6 @@ globalCommand commands = CommandUI { globalHttpTransport (\v flags -> flags { globalHttpTransport = v }) (reqArgFlag "HttpTransport") - , option [] ["http-transport-config"] - "Set extra arguments for an http transport that is configured with 'http-transport' option." - globalHttpTransportFlags (\v flags -> flags { globalHttpTransportFlags = v }) - -- TODO: FIX IT - undefined - -- (reqArg' "ARGS" (\x -> toNubList []) fromNubList) - ,option [] ["nix"] "Nix integration: run commands through nix-shell if a 'shell.nix' file exists" globalNix (\v flags -> flags { globalNix = v }) From 272019d62b6d9bea89764d2ce0daaf7957e72805 Mon Sep 17 00:00:00 2001 From: David Turnbull Date: Fri, 2 Aug 2019 09:51:30 +1000 Subject: [PATCH 07/13] use "curl -n" so that it will use .netrc For private hackage repos that require authentication, you must use the wgetTransport. But this is slow, so we want to use curlTransport. curlTransport doesn't understand auth embedded in URIs, but .netrc is a nice way of doing it that wget could also understand. --- cabal-install/Distribution/Client/HttpUtils.hs | 7 +++++++ cabal-install/Distribution/Client/Setup.hs | 2 +- cabal-install/changelog | 1 + 3 files changed, 9 insertions(+), 1 deletion(-) diff --git a/cabal-install/Distribution/Client/HttpUtils.hs b/cabal-install/Distribution/Client/HttpUtils.hs index 1fd8ae86b2b..e387140fea5 100644 --- a/cabal-install/Distribution/Client/HttpUtils.hs +++ b/cabal-install/Distribution/Client/HttpUtils.hs @@ -59,6 +59,7 @@ import System.IO.Error import Distribution.Simple.Program ( Program, simpleProgram, ConfiguredProgram, programPath , ProgramInvocation(..), programInvocation + , programOverrideArgs, programPostConf , ProgramSearchPathEntry(..) , getProgramInvocationOutput ) import Distribution.Simple.Program.Db @@ -254,6 +255,12 @@ supportedTransports = ( "curl", Just prog, True , \db -> curlTransport <$> lookupProgram prog db ) + , let prog = (simpleProgram "curl") { programPostConf = post } + args = ["-n"] + post = \_ p -> return p { programOverrideArgs = args } in + ( "curlnetrc", Just prog, True + , \db -> curlTransport <$> lookupProgram prog db ) + , let prog = simpleProgram "wget" in ( "wget", Just prog, True , \db -> wgetTransport <$> lookupProgram prog db ) diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index 1ac7f0731c8..7285066375e 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -405,7 +405,7 @@ globalCommand commands = CommandUI { trueArg ,option [] ["http-transport"] - "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')" + "Set a transport for http(s) requests. Accepts 'curl', 'curlnetrc', 'wget', 'powershell', and 'plain-http'. (default: 'curl')" globalHttpTransport (\v flags -> flags { globalHttpTransport = v }) (reqArgFlag "HttpTransport") 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) From e19b3d1f3bec9d7aa8bc3a20986dadc64c092d2a Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 9 Aug 2019 13:40:21 +1000 Subject: [PATCH 08/13] Wire up transport flags --- .../Distribution/Client/GlobalFlags.hs | 27 ++++++++++------ .../Distribution/Client/HttpUtils.hs | 31 +++++++++++-------- .../Distribution/Client/ProjectConfig.hs | 9 +++++- .../Client/ProjectConfig/Legacy.hs | 1 + .../Client/ProjectConfig/Types.hs | 5 ++- 5 files changed, 48 insertions(+), 25 deletions(-) diff --git a/cabal-install/Distribution/Client/GlobalFlags.hs b/cabal-install/Distribution/Client/GlobalFlags.hs index a86721b915d..5b5ecfb9e4a 100644 --- a/cabal-install/Distribution/Client/GlobalFlags.hs +++ b/cabal-install/Distribution/Client/GlobalFlags.hs @@ -68,7 +68,7 @@ data GlobalFlags = GlobalFlags { globalIgnoreSandbox :: Flag Bool, globalIgnoreExpiry :: Flag Bool, -- ^ Ignore security expiry dates globalHttpTransport :: Flag String, - globalHttpTransportFlags :: NubList HttpTransportFlags, + globalHttpTransportFlags :: NubList 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) @@ -143,20 +143,27 @@ 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)) + (fromNubList (globalHttpTransportFlags globalFlags)) + (flagToMaybe (globalIgnoreExpiry globalFlags)) + (fromNubList (globalProgPathExtra globalFlags)) + +lookupTransportFlags :: Maybe String -> [HttpTransportFlags] -> Maybe HttpTransportFlags +lookupTransportFlags (Just httpTransport) fs = find ((== httpTransport) . httpTransportFlagsName) fs +lookupTransportFlags Nothing _ = Nothing withRepoContext' :: Verbosity -> [RemoteRepo] -> [FilePath] - -> FilePath -> Maybe String -> Maybe Bool + -> FilePath -> Maybe String -> [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 @@ -184,7 +191,7 @@ withRepoContext' verbosity remoteRepos localRepos modifyMVar transportRef $ \mTransport -> do transport <- case mTransport of Just tr -> return tr - Nothing -> configureTransport verbosity extraPaths httpTransport + Nothing -> configureTransport verbosity extraPaths (lookupTransportFlags httpTransport httpTransportFlags) 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 e387140fea5..4724cb4b8c1 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 @@ -249,33 +249,34 @@ 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 htf -> curlTransport htf <$> lookupProgram prog db) , let prog = (simpleProgram "curl") { programPostConf = post } args = ["-n"] post = \_ p -> return p { programOverrideArgs = args } in ( "curlnetrc", Just prog, True - , \db -> curlTransport <$> lookupProgram prog db ) + , \db htf -> curlTransport htf <$> lookupProgram prog db ) , let prog = simpleProgram "wget" in ( "wget", Just prog, True - , \db -> wgetTransport <$> lookupProgram prog db ) + , \db _ -> wgetTransport <$> 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 @@ -288,7 +289,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 @@ -311,7 +312,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 @@ -323,14 +324,17 @@ 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 withTempFile (takeDirectory destPath) "curl-headers.txt" $ \tmpFile tmpHandle -> do hClose tmpHandle + let netrcFlags = case httpTransportFlagsUseNetrc httpTransportFlags of + Just True -> ["--netrc"] + _ -> [] let args = [ show uri , "--output", destPath , "--location" @@ -338,6 +342,7 @@ curlTransport prog = , "--user-agent", userAgent , "--silent", "--show-error" , "--dump-header", tmpFile ] + ++ netrcFlags ++ concat [ ["--header", "If-None-Match: " ++ t] | t <- maybeToList etag ] diff --git a/cabal-install/Distribution/Client/ProjectConfig.hs b/cabal-install/Distribution/Client/ProjectConfig.hs index 23e3cd987e7..c74e0a6f043 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) + (fromNubList projectConfigHttpTransportFlags) (flagToMaybe projectConfigIgnoreExpiry) (fromNubList projectConfigProgPathExtra) @@ -314,6 +316,7 @@ resolveBuildTimeSettings verbosity buildSettingLocalRepos = fromNubList projectConfigLocalRepos buildSettingCacheDir = fromFlag projectConfigCacheDir buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport + buildSettingHttpTransportFlags = fromNubList 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 -> [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 + (fromNubList (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 e172bcabcdd..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 diff --git a/cabal-install/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/Distribution/Client/ProjectConfig/Types.hs index 7472102c9b3..da58a707976 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 :: NubList HttpTransportFlags, projectConfigIgnoreExpiry :: Flag Bool, projectConfigCacheDir :: Flag FilePath, projectConfigLogsDir :: Flag FilePath, @@ -439,6 +441,7 @@ data BuildTimeSettings buildSettingLocalRepos :: [FilePath], buildSettingCacheDir :: FilePath, buildSettingHttpTransport :: Maybe String, + buildSettingHttpTransportFlags :: [HttpTransportFlags], buildSettingIgnoreExpiry :: Bool, buildSettingProgPathExtra :: [FilePath] } From 789c1c88fed62c7b651597f4f05d603d0868446d Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 9 Aug 2019 14:49:52 +1000 Subject: [PATCH 09/13] Make netrc configurable for wget transport as well --- .../Distribution/Client/HttpUtils.hs | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/cabal-install/Distribution/Client/HttpUtils.hs b/cabal-install/Distribution/Client/HttpUtils.hs index 4724cb4b8c1..ccd05fcd9d6 100644 --- a/cabal-install/Distribution/Client/HttpUtils.hs +++ b/cabal-install/Distribution/Client/HttpUtils.hs @@ -59,7 +59,6 @@ import System.IO.Error import Distribution.Simple.Program ( Program, simpleProgram, ConfiguredProgram, programPath , ProgramInvocation(..), programInvocation - , programOverrideArgs, programPostConf , ProgramSearchPathEntry(..) , getProgramInvocationOutput ) import Distribution.Simple.Program.Db @@ -253,17 +252,11 @@ supportedTransports :: [(String, Maybe Program, Bool, supportedTransports = [ let prog = simpleProgram "curl" in ( "curl", Just prog, True - , \db htf -> curlTransport htf <$> lookupProgram prog db) - - , let prog = (simpleProgram "curl") { programPostConf = post } - args = ["-n"] - post = \_ p -> return p { programOverrideArgs = args } in - ( "curlnetrc", Just prog, True - , \db htf -> curlTransport htf <$> 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 @@ -425,8 +418,8 @@ curlTransport httpTransportFlags 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 @@ -447,11 +440,15 @@ wgetTransport prog = (code, etag') <- parseOutput verbosity uri resp return (code, etag') where + netrcFlags = case httpTransportFlagsUseNetrc httpTransportFlags of + Just False -> ["--no-netrc"] + _ -> [] args = [ "--output-document=" ++ destPath , "--user-agent=" ++ userAgent , "--tries=5" , "--timeout=15" , "--server-response" ] + ++ netrcFlags ++ concat [ ["--header", "If-None-Match: " ++ t] | t <- maybeToList etag ] From 0992e83ab51e11091d3d8e89792e270c3f0a8478 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 9 Aug 2019 14:52:55 +1000 Subject: [PATCH 10/13] Remove curlnetrc transport --- cabal-install/Distribution/Client/Setup.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index 7285066375e..1ac7f0731c8 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -405,7 +405,7 @@ globalCommand commands = CommandUI { trueArg ,option [] ["http-transport"] - "Set a transport for http(s) requests. Accepts 'curl', 'curlnetrc', 'wget', 'powershell', and 'plain-http'. (default: 'curl')" + "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')" globalHttpTransport (\v flags -> flags { globalHttpTransport = v }) (reqArgFlag "HttpTransport") From 3e5ad5a549929c5f85ad712fb3d13fe37410031e Mon Sep 17 00:00:00 2001 From: alexeyraga Date: Fri, 9 Aug 2019 15:54:07 +1000 Subject: [PATCH 11/13] From list to Maybe: Doesn't compile --- cabal-install/Distribution/Client/Config.hs | 21 ++++++++++--------- .../Distribution/Client/GlobalFlags.hs | 13 ++++++------ 2 files changed, 18 insertions(+), 16 deletions(-) diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 22fb92adbe4..a1bef7ce45d 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -255,7 +255,7 @@ instance Semigroup SavedConfig where globalIgnoreSandbox = combine globalIgnoreSandbox, globalIgnoreExpiry = combine globalIgnoreExpiry, globalHttpTransport = combine globalHttpTransport, - globalHttpTransportFlags = lastNonEmptyNL globalHttpTransportFlags, + globalHttpTransportFlags = combine globalHttpTransportFlags, globalNix = combine globalNix, globalStoreDir = combine globalStoreDir, globalProgPathExtra = lastNonEmptyNL globalProgPathExtra @@ -1089,13 +1089,14 @@ parseConfig src initial = \str -> do let init0 = savedInitFlags config user0 = savedUserInstallDirs config global0 = savedGlobalInstallDirs config - (httpTransportSections0, 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 httpTransportSections = nubBy ((==) `on` httpTransportFlagsName) httpTransportSections0 - let remoteRepoSections = reverse . nubBy ((==) `on` remoteRepoName) @@ -1103,7 +1104,7 @@ parseConfig src initial = \str -> do return . fixConfigMultilines $ config { savedGlobalFlags = (savedGlobalFlags config) { - globalHttpTransportFlags = toNubList httpTransportSections, + globalHttpTransportFlags = http, globalRemoteRepos = toNubList remoteRepoSections, -- the global extra prog path comes from the configure flag prog path globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config) @@ -1126,7 +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-flags" _ _) = True + isKnownSection (ParseUtils.Section _ "http-transport" _ _) = True isKnownSection _ = False -- attempt to split fields that can represent lists of paths into actual lists @@ -1155,9 +1156,9 @@ parseConfig src initial = \str -> do ++ deprecatedFieldDescriptions) initial parseSections (ts, rs, h, i, u, g, p, a) - (ParseUtils.Section _ "http-transport-config" name fs) = do - t' <- parseFields httpTransportFields (emptyHttpTransportFlags name) fs - return (t':ts, rs, h, i, u, g, p, a) + (ParseUtils.Section _ "http-transport" name fs) = do + ts' <- parseFields httpTransportFields (emptyHttpTransportFlags name) fs + return (ts', rs, h, i, u, g, p, a) parseSections (ts, rs, h, i, u, g, p, a) (ParseUtils.Section _ "repository" name fs) = do diff --git a/cabal-install/Distribution/Client/GlobalFlags.hs b/cabal-install/Distribution/Client/GlobalFlags.hs index 5b5ecfb9e4a..7d46e6c3615 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(..), HttpTransportFlags(..) ) + ( Repo(..), RemoteRepo(..) + , HttpTransportFlags(..), emptyHttpTransportFlags ) import Distribution.Simple.Setup ( Flag(..), fromFlag, flagToMaybe ) import Distribution.Utils.NubList @@ -68,7 +69,7 @@ data GlobalFlags = GlobalFlags { globalIgnoreSandbox :: Flag Bool, globalIgnoreExpiry :: Flag Bool, -- ^ Ignore security expiry dates globalHttpTransport :: Flag String, - globalHttpTransportFlags :: NubList HttpTransportFlags, + 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) @@ -90,7 +91,7 @@ defaultGlobalFlags = GlobalFlags { globalIgnoreSandbox = Flag False, globalIgnoreExpiry = Flag False, globalHttpTransport = mempty, - globalHttpTransportFlags = mempty, + globalHttpTransportFlags = Flag (emptyHttpTransportFlags "curl"), globalNix = Flag False, globalStoreDir = mempty, globalProgPathExtra = mempty @@ -147,16 +148,16 @@ withRepoContext verbosity globalFlags = (fromNubList (globalLocalRepos globalFlags)) (fromFlag (globalCacheDir globalFlags)) (flagToMaybe (globalHttpTransport globalFlags)) - (fromNubList (globalHttpTransportFlags globalFlags)) + (flagToMaybe (globalHttpTransportFlags globalFlags)) (flagToMaybe (globalIgnoreExpiry globalFlags)) (fromNubList (globalProgPathExtra globalFlags)) -lookupTransportFlags :: Maybe String -> [HttpTransportFlags] -> Maybe HttpTransportFlags +lookupTransportFlags :: Maybe String -> Maybe HttpTransportFlags -> Maybe HttpTransportFlags lookupTransportFlags (Just httpTransport) fs = find ((== httpTransport) . httpTransportFlagsName) fs lookupTransportFlags Nothing _ = Nothing withRepoContext' :: Verbosity -> [RemoteRepo] -> [FilePath] - -> FilePath -> Maybe String -> [HttpTransportFlags] -> Maybe Bool + -> FilePath -> Maybe String -> Maybe HttpTransportFlags -> Maybe Bool -> [FilePath] -> (RepoContext -> IO a) -> IO a From c03ead17c34cf7e244ece0b5ba4daff3f35d375e Mon Sep 17 00:00:00 2001 From: alexeyraga Date: Fri, 9 Aug 2019 16:41:31 +1000 Subject: [PATCH 12/13] Reconfigure transport --- cabal-install/Distribution/Client/Config.hs | 4 ++-- cabal-install/Distribution/Client/GlobalFlags.hs | 14 ++++++++------ cabal-install/Distribution/Client/ProjectConfig.hs | 8 ++++---- .../Distribution/Client/ProjectConfig/Types.hs | 4 ++-- 4 files changed, 16 insertions(+), 14 deletions(-) diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index a1bef7ce45d..fa81a1d4441 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -1155,10 +1155,10 @@ parseConfig src initial = \str -> do parse = parseFields (configFieldDescriptions src ++ deprecatedFieldDescriptions) initial - parseSections (ts, 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 (ts', rs, h, i, u, g, p, a) + 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 diff --git a/cabal-install/Distribution/Client/GlobalFlags.hs b/cabal-install/Distribution/Client/GlobalFlags.hs index 7d46e6c3615..31ec13ee62b 100644 --- a/cabal-install/Distribution/Client/GlobalFlags.hs +++ b/cabal-install/Distribution/Client/GlobalFlags.hs @@ -91,7 +91,7 @@ defaultGlobalFlags = GlobalFlags { globalIgnoreSandbox = Flag False, globalIgnoreExpiry = Flag False, globalHttpTransport = mempty, - globalHttpTransportFlags = Flag (emptyHttpTransportFlags "curl"), + globalHttpTransportFlags = mempty, globalNix = Flag False, globalStoreDir = mempty, globalProgPathExtra = mempty @@ -152,10 +152,6 @@ withRepoContext verbosity globalFlags = (flagToMaybe (globalIgnoreExpiry globalFlags)) (fromNubList (globalProgPathExtra globalFlags)) -lookupTransportFlags :: Maybe String -> Maybe HttpTransportFlags -> Maybe HttpTransportFlags -lookupTransportFlags (Just httpTransport) fs = find ((== httpTransport) . httpTransportFlagsName) fs -lookupTransportFlags Nothing _ = Nothing - withRepoContext' :: Verbosity -> [RemoteRepo] -> [FilePath] -> FilePath -> Maybe String -> Maybe HttpTransportFlags -> Maybe Bool -> [FilePath] @@ -192,7 +188,13 @@ withRepoContext' verbosity remoteRepos localRepos modifyMVar transportRef $ \mTransport -> do transport <- case mTransport of Just tr -> return tr - Nothing -> configureTransport verbosity extraPaths (lookupTransportFlags httpTransport httpTransportFlags) + 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/ProjectConfig.hs b/cabal-install/Distribution/Client/ProjectConfig.hs index c74e0a6f043..eaefb57667b 100644 --- a/cabal-install/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/Distribution/Client/ProjectConfig.hs @@ -211,7 +211,7 @@ projectConfigWithSolverRepoContext verbosity "projectConfigWithSolverRepoContext: projectConfigCacheDir") projectConfigCacheDir) (flagToMaybe projectConfigHttpTransport) - (fromNubList projectConfigHttpTransportFlags) + (flagToMaybe projectConfigHttpTransportFlags) (flagToMaybe projectConfigIgnoreExpiry) (fromNubList projectConfigProgPathExtra) @@ -316,7 +316,7 @@ resolveBuildTimeSettings verbosity buildSettingLocalRepos = fromNubList projectConfigLocalRepos buildSettingCacheDir = fromFlag projectConfigCacheDir buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport - buildSettingHttpTransportFlags = fromNubList projectConfigHttpTransportFlags + buildSettingHttpTransportFlags = flagToMaybe projectConfigHttpTransportFlags buildSettingIgnoreExpiry = fromFlag projectConfigIgnoreExpiry buildSettingReportPlanningFailure = fromFlag projectConfigReportPlanningFailure @@ -954,7 +954,7 @@ mplusMaybeT ma mb = do Nothing -> mb Just x -> return (Just x) -lookupTransportFlags :: Maybe String -> [HttpTransportFlags] -> Maybe HttpTransportFlags +lookupTransportFlags :: Maybe String -> Maybe HttpTransportFlags -> Maybe HttpTransportFlags lookupTransportFlags (Just httpTransport) fs = find ((== httpTransport) . httpTransportFlagsName) fs lookupTransportFlags Nothing _ = Nothing @@ -995,7 +995,7 @@ fetchAndReadSourcePackages verbosity distDirLayout getTransport <- delayInitSharedResource $ configureTransport verbosity progPathExtra ( lookupTransportFlags preferredHttpTransport - (fromNubList (projectConfigHttpTransportFlags projectConfigBuildOnly))) + (flagToMaybe (projectConfigHttpTransportFlags projectConfigBuildOnly))) sequence [ fetchAndReadSourcePackageRemoteTarball verbosity distDirLayout getTransport uri diff --git a/cabal-install/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/Distribution/Client/ProjectConfig/Types.hs index da58a707976..365ada6a186 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Types.hs @@ -151,7 +151,7 @@ data ProjectConfigBuildOnly projectConfigOfflineMode :: Flag Bool, projectConfigKeepTempFiles :: Flag Bool, projectConfigHttpTransport :: Flag String, - projectConfigHttpTransportFlags :: NubList HttpTransportFlags, + projectConfigHttpTransportFlags :: Flag HttpTransportFlags, projectConfigIgnoreExpiry :: Flag Bool, projectConfigCacheDir :: Flag FilePath, projectConfigLogsDir :: Flag FilePath, @@ -441,7 +441,7 @@ data BuildTimeSettings buildSettingLocalRepos :: [FilePath], buildSettingCacheDir :: FilePath, buildSettingHttpTransport :: Maybe String, - buildSettingHttpTransportFlags :: [HttpTransportFlags], + buildSettingHttpTransportFlags :: Maybe HttpTransportFlags, buildSettingIgnoreExpiry :: Bool, buildSettingProgPathExtra :: [FilePath] } From 0e677b3c7c9d35a060ccd96c4f949d204f6dccde Mon Sep 17 00:00:00 2001 From: David Turnbull Date: Fri, 9 Aug 2019 18:58:34 +1000 Subject: [PATCH 13/13] set netrcFlags on all methods of both curl and wget transports --- .../Distribution/Client/HttpUtils.hs | 20 +++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/cabal-install/Distribution/Client/HttpUtils.hs b/cabal-install/Distribution/Client/HttpUtils.hs index ccd05fcd9d6..de19f317edc 100644 --- a/cabal-install/Distribution/Client/HttpUtils.hs +++ b/cabal-install/Distribution/Client/HttpUtils.hs @@ -325,9 +325,6 @@ curlTransport httpTransportFlags prog = withTempFile (takeDirectory destPath) "curl-headers.txt" $ \tmpFile tmpHandle -> do hClose tmpHandle - let netrcFlags = case httpTransportFlagsUseNetrc httpTransportFlags of - Just True -> ["--netrc"] - _ -> [] let args = [ show uri , "--output", destPath , "--location" @@ -371,6 +368,7 @@ curlTransport httpTransportFlags prog = , "--header", "Accept: text/plain" , "--location" ] + ++ netrcFlags resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth (programInvocation prog args) (code, err, _etag) <- parseResponse verbosity uri resp "" @@ -385,6 +383,7 @@ curlTransport httpTransportFlags prog = , "--location" , "--header", "Accept: text/plain" ] + ++ netrcFlags ++ concat [ ["--header", show name ++ ": " ++ value] | Header name value <- headers ] @@ -393,6 +392,10 @@ curlTransport httpTransportFlags 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) @@ -440,15 +443,11 @@ wgetTransport httpTransportFlags prog = (code, etag') <- parseOutput verbosity uri resp return (code, etag') where - netrcFlags = case httpTransportFlagsUseNetrc httpTransportFlags of - Just False -> ["--no-netrc"] - _ -> [] args = [ "--output-document=" ++ destPath , "--user-agent=" ++ userAgent , "--tries=5" , "--timeout=15" , "--server-response" ] - ++ netrcFlags ++ concat [ ["--header", "If-None-Match: " ++ t] | t <- maybeToList etag ] @@ -512,10 +511,15 @@ wgetTransport httpTransportFlags 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 "") }