ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 05:48:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

download: Support 'https_proxy'.

Browse source 
* 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
Show stats Download patch file Download diff file Expand all files Collapse all files

28
guix/build/download.scm
View file

@ -380,6 +380,20 @@ (define addresses
(apply throw args)
(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
#:key
timeout
@ -393,21 +407,20 @@ (define* (open-connection-for-uri uri
(define https?
(eq? 'https (uri-scheme uri)))
(define https-proxy (let ((proxy (getenv "https_proxy")))
(and (not (equal? proxy ""))
proxy)))
(let-syntax ((with-https-proxy
(syntax-rules ()
((_ exp)
;; For HTTPS URIs, honor 'https_proxy', not 'http_proxy'.
;; FIXME: Proxying is not supported for https.
(let ((thunk (lambda () exp)))
(if (and https?
(module-variable
(resolve-interface '(web client))
'current-http-proxy))
(parameterize ((current-http-proxy #f))
(when (and=> (getenv "https_proxy")
(negate string-null?))
(format (current-error-port)
"warning: 'https_proxy' is ignored~%"))
(parameterize ((current-http-proxy https-proxy))
(thunk))
(thunk)))))))
(with-https-proxy
@ -415,6 +428,9 @@ (define https?
;; Buffer input and output on this port.
(setvbuf s 'block %http-receive-buffer-size)
(when (and https? https-proxy)
(setup-http-tunnel s uri))
(if https?
(tls-wrap s (uri-host uri)
#:verify-certificate? verify-certificate?)