download: Support 'https_proxy'.

* guix/build/download.scm (setup-http-tunnel): New procedure.
(open-connection-for-uri): Honor the 'https_proxy' environment variable.
This commit is contained in:
宋文武 2019-05-10 21:27:40 +08:00
parent 4074ee4ef7
commit 9bc8175cfa
No known key found for this signature in database
GPG Key ID: D415BF253B515976
1 changed files with 22 additions and 6 deletions

View File

@ -380,6 +380,20 @@ ETIMEDOUT error is raised."
(apply throw args) (apply throw args)
(loop (cdr addresses)))))))) (loop (cdr addresses))))))))
(define (setup-http-tunnel port uri)
"Establish over PORT an HTTP tunnel to the destination server of URI."
(define target
(string-append (uri-host uri) ":"
(number->string
(or (uri-port uri)
(match (uri-scheme uri)
('http 80)
('https 443))))))
(format port "CONNECT ~a HTTP/1.1\r\n" target)
(format port "Host: ~a\r\n\r\n" target)
(force-output port)
(read-response port))
(define* (open-connection-for-uri uri (define* (open-connection-for-uri uri
#:key #:key
timeout timeout
@ -393,21 +407,20 @@ VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
(define https? (define https?
(eq? 'https (uri-scheme uri))) (eq? 'https (uri-scheme uri)))
(define https-proxy (let ((proxy (getenv "https_proxy")))
(and (not (equal? proxy ""))
proxy)))
(let-syntax ((with-https-proxy (let-syntax ((with-https-proxy
(syntax-rules () (syntax-rules ()
((_ exp) ((_ exp)
;; For HTTPS URIs, honor 'https_proxy', not 'http_proxy'. ;; For HTTPS URIs, honor 'https_proxy', not 'http_proxy'.
;; FIXME: Proxying is not supported for https.
(let ((thunk (lambda () exp))) (let ((thunk (lambda () exp)))
(if (and https? (if (and https?
(module-variable (module-variable
(resolve-interface '(web client)) (resolve-interface '(web client))
'current-http-proxy)) 'current-http-proxy))
(parameterize ((current-http-proxy #f)) (parameterize ((current-http-proxy https-proxy))
(when (and=> (getenv "https_proxy")
(negate string-null?))
(format (current-error-port)
"warning: 'https_proxy' is ignored~%"))
(thunk)) (thunk))
(thunk))))))) (thunk)))))))
(with-https-proxy (with-https-proxy
@ -415,6 +428,9 @@ VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
;; Buffer input and output on this port. ;; Buffer input and output on this port.
(setvbuf s 'block %http-receive-buffer-size) (setvbuf s 'block %http-receive-buffer-size)
(when (and https? https-proxy)
(setup-http-tunnel s uri))
(if https? (if https?
(tls-wrap s (uri-host uri) (tls-wrap s (uri-host uri)
#:verify-certificate? verify-certificate?) #:verify-certificate? verify-certificate?)