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:
parent
4074ee4ef7
commit
9bc8175cfa
|
@ -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?)
|
||||||
|
|
Loading…
Reference in New Issue