01/01: download: Support 'https_proxy'.

[guix-commits]

iyzsong pushed a commit to branch master
in repository guix.

commit 9bc8175cfa6b23c31f6c43531377d266456e430e
Author: 宋文武 <address@hidden>
Date:   Fri May 10 21:27:40 2019 +0800

    download: Support 'https_proxy'.
    
    * guix/build/download.scm (setup-http-tunnel): New procedure.
    (open-connection-for-uri): Honor the 'https_proxy' environment variable.
---
 guix/build/download.scm | 28 ++++++++++++++++++++++------
 1 file changed, 22 insertions(+), 6 deletions(-)

diff --git a/guix/build/download.scm b/guix/build/download.scm
index a64e0f0..0c9c61d 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -380,6 +380,20 @@ ETIMEDOUT error is raised."
               (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 @@ VERIFY-CERTIFICATE? is true, verify HTTPS server 
certificates."
   (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 @@ VERIFY-CERTIFICATE? is true, verify HTTPS server 
certificates."
        ;; 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?)