Merge branch 'master' into core-updates

6 files changed, 45 insertions, 45 deletions

diff --git a/guix/build/download.scm b/guix/build/download.scm
index a3105ad41d..2e0b019d38 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -196,46 +196,31 @@ host name without trailing dot."
       record)))
 
 (define (open-connection-for-uri uri)
-  "Return an open input/output port for a connection to URI.
-
-This is the same as Guile's `open-socket-for-uri', except that we always
-use a numeric port argument, to avoid the need to go through libc's NSS,
-which is not available during bootstrap."
-  (define addresses
-    (let ((port (or (uri-port uri)
-                    (case (uri-scheme uri)
-                      ((http) 80)           ; /etc/services, not for me!
-                      ((https) 443)
-                      (else
-                       (error "unsupported URI scheme" uri))))))
-      (delete-duplicates (getaddrinfo (uri-host uri)
-                                      (number->string port)
-                                      AI_NUMERICSERV)
-                         (lambda (ai1 ai2)
-                           (equal? (addrinfo:addr ai1)
-                                   (addrinfo:addr ai2))))))
-
-  (let loop ((addresses addresses))
-    (let* ((ai (car addresses))
-           (s  (with-fluids ((%default-port-encoding #f))
-                 ;; Restrict ourselves to TCP.
-                 (socket (addrinfo:fam ai) SOCK_STREAM IPPROTO_IP))))
-      (catch 'system-error
-        (lambda ()
-          (connect s (addrinfo:addr ai))
-
-          ;; Buffer input and output on this port.
-          (setvbuf s _IOFBF %http-receive-buffer-size)
-
-          (if (eq? 'https (uri-scheme uri))
-              (tls-wrap s (uri-host uri))
-              s))
-        (lambda args
-          ;; Connection failed, so try one of the other addresses.
-          (close s)
-          (if (null? (cdr addresses))
-              (apply throw args)
-              (loop (cdr addresses))))))))
+  "Like 'open-socket-for-uri', but also handle HTTPS connections."
+  (define https?
+    (eq? 'https (uri-scheme uri)))
+
+  (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 (getenv "https_proxy")
+                             (format (current-error-port)
+                                     "warning: 'https_proxy' is ignored~%"))
+                           (thunk))
+                         (thunk)))))))
+    (with-https-proxy
+     (let ((s (open-socket-for-uri uri)))
+       (if https?
+           (tls-wrap s (uri-host uri))
+           s)))))
 
 ;; XXX: This is an awful hack to make sure the (set-port-encoding! p
 ;; "ISO-8859-1") call in `read-response' passes, even during bootstrap
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 7737e39b2d..1056caa70a 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -692,7 +692,7 @@ HASH-ALGO, of the derivation NAME.  RECURSIVE? has the same meaning as for
                      (inputs '()) (outputs '("out"))
                      hash hash-algo recursive?
                      references-graphs allowed-references
-                     local-build?)
+                     leaked-env-vars local-build?)
   "Build a derivation with the given arguments, and return the resulting
 <derivation> object.  When HASH and HASH-ALGO are given, a
 fixed-output derivation is created---i.e., one whose result is known in
@@ -707,6 +707,12 @@ the build environment in the corresponding file, in a simple text format.
 When ALLOWED-REFERENCES is true, it must be a list of store items or outputs
 that the derivation's output may refer to.
 
+When LEAKED-ENV-VARS is true, it must be a list of strings denoting
+environment variables that are allowed to \"leak\" from the daemon's
+environment to the build environment.  This is only applicable to fixed-output
+derivations--i.e., when HASH is true.  The main use is to allow variables such
+as \"http_proxy\" to be passed to derivations that download files.
+
 When LOCAL-BUILD? is true, declare that the derivation is not a good candidate
 for offloading and should rather be built locally.  This is the case for small
 derivations where the costs of data transfers would outweigh the benefits."
@@ -751,6 +757,10 @@ derivations where the costs of data transfers would outweigh the benefits."
                             `(("allowedReferences"
                                . ,(string-join allowed-references)))
                             '())
+                      ,@(if leaked-env-vars
+                            `(("impureEnvVars"
+                               . ,(string-join leaked-env-vars)))
+                            '())
                       ,@env-vars)))
       (match references-graphs
         (((file . path) ...)
diff --git a/guix/download.scm b/guix/download.scm
index 3e4024fe1f..6b0349402a 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -271,6 +271,9 @@ in the store."
                                         (guix build utils)
                                         (guix ftp-client))
 
+                            ;; Honor the user's proxy settings.
+                            #:leaked-env-vars '("http_proxy" "https_proxy")
+
                             ;; In general, offloading downloads is not a good idea.
                             ;;#:local-build? #t
                             ;; FIXME: The above would also disable use of
diff --git a/guix/gexp.scm b/guix/gexp.scm
index a2da72e76c..b08a361232 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -282,6 +282,7 @@ names and file names suitable for the #:allowed-references argument to
                            (graft? (%graft?))
                            references-graphs
                            allowed-references
+                           leaked-env-vars
                            local-build?)
   "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
 derivation) on SYSTEM.  When TARGET is true, it is used as the
@@ -400,6 +401,7 @@ The other arguments are as for 'derivation'."
                       #:hash hash #:hash-algo hash-algo #:recursive? recursive?
                       #:references-graphs (and=> graphs graphs-file-names)
                       #:allowed-references allowed
+                      #:leaked-env-vars leaked-env-vars
                       #:local-build? local-build?))))
 
 (define* (gexp-inputs exp #:key native?)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index adf94a7ac3..b9983c5b9c 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -467,6 +467,7 @@ to read the response body.  Return the list of results."
              ;; case we have to try again.  Check whether that is the case.
              (match (assq 'connection (response-headers resp))
                (('connection 'close)
+                (close-port p)
                 (connect requests result))        ;try again
                (_
                 (loop tail                        ;keep going
diff --git a/guix/serialization.scm b/guix/serialization.scm
index a99f53ee0b..51d7ef76c6 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -140,10 +140,9 @@ substitute invalid byte sequences with question marks.  This is a
   ;; not very efficient.  Eventually Guile may provide a lightweight
   ;; permissive UTF-8 decoder.
   (let* ((bv   (read-byte-string p))
-         (port (with-fluids ((%default-port-encoding "UTF-8")
-                             (%default-port-conversion-strategy
-                              'substitute))
-                 (open-bytevector-input-port bv))))
+         (port (open-bytevector-input-port bv)))
+    (set-port-encoding! port "UTF-8")
+    (set-port-conversion-strategy! port 'substitute)
     (get-string-all port)))
 
 (define (write-string-list l p)