[Guile-commits] 02/06: web: Add 'current-https-proxy' and honor $https_proxy.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guile.

commit 80bbebef4d055dfdefd47cd754eb9ad625e33b54
Author: Ludovic Courtès <address@hidden>
AuthorDate: Fri Jan 10 12:01:39 2020 +0100

    web: Add 'current-https-proxy' and honor $https_proxy.
    
    * module/web/client.scm (current-https-proxy): New variable.
    (setup-http-tunnel): New procedure.
    (open-socket-for-uri): Move 'http-proxy', 'uri', and 'addresses' inside
    'open-socket'.  Remove 'with-https-proxy' macro.  Add call to
    'setup-http-tunnel'.  Honor 'current-https-proxy' in 'open-socket'.
    * doc/ref/web.texi (Web Client): Document 'current-https-proxy'.
    * doc/ref/guile.texi: Update copyright years.
    
    Based on Guix commit 9bc8175cfa6b23c31f6c43531377d266456e430e.
    
    Co-authored-by: Sou Bunnbu (宋文武) <address@hidden>
---
 doc/ref/web.texi      |  7 +++--
 module/web/client.scm | 87 +++++++++++++++++++++++++++++----------------------
 2 files changed, 54 insertions(+), 40 deletions(-)

diff --git a/doc/ref/web.texi b/doc/ref/web.texi
index c642d04..91b3a4e 100644
--- a/doc/ref/web.texi
+++ b/doc/ref/web.texi
@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 2010, 2011, 2012, 2013, 2015, 2018, 2019 Free Software 
Foundation, Inc.
+@c Copyright (C) 2010, 2011, 2012, 2013, 2015, 2018, 2019, 2020 Free Software 
Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
 @node Web
@@ -1540,10 +1540,11 @@ Another option, good but not as performant, would be to 
use threads,
 possibly via par-map or futures.
 
 @deffn {Scheme Parameter} current-http-proxy
+@deffnx {Scheme Parameter} current-https-proxy
 Either @code{#f} or a non-empty string containing the URL of the HTTP
-proxy server to be used by the procedures in the @code{(web client)}
+or HTTPS proxy server to be used by the procedures in the @code{(web client)}
 module, including @code{open-socket-for-uri}.  Its initial value is
-based on the @env{http_proxy} environment variable.
+based on the @env{http_proxy} and @env{https_proxy} environment variables.
 
 @example
 (current-http-proxy) @result{} "http://localhost:8123/";
diff --git a/module/web/client.scm b/module/web/client.scm
index 874b04d..3761eb5 100644
--- a/module/web/client.scm
+++ b/module/web/client.scm
@@ -45,7 +45,9 @@
   #:use-module (srfi srfi-9 gnu)
   #:use-module ((rnrs io ports)
                 #:prefix rnrs-ports:)
+  #:use-module (ice-9 match)
   #:export (current-http-proxy
+            current-https-proxy
             open-socket-for-uri
             http-request
             http-get
@@ -83,6 +85,11 @@ if it is unavailable."
                     (and (not (equal? proxy ""))
                          proxy))))
 
+(define current-https-proxy
+  (make-parameter (let ((proxy (getenv "https_proxy")))
+                    (and (not (equal? proxy ""))
+                         proxy))))
+
 (define (tls-wrap port server)
   "Return PORT wrapped in a TLS connection to SERVER.  SERVER must be a DNS
 host name without trailing dot."
@@ -159,25 +166,44 @@ host name without trailing dot."
    ((uri-reference? uri-or-string) uri-or-string)
    (else (error "Invalid URI-reference" uri-or-string))))
 
+(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-socket-for-uri uri-or-string)
   "Return an open input/output port for a connection to URI."
-  (define http-proxy (current-http-proxy))
-  (define uri (ensure-uri-reference (or http-proxy uri-or-string)))
-  (define addresses
-    (let ((port (uri-port uri)))
-      (delete-duplicates
-       (getaddrinfo (uri-host uri)
-                    (cond (port => number->string)
-                          ((uri-scheme uri) => symbol->string)
-                          (else (error "Not an absolute URI" uri)))
-                    (if port
-                        AI_NUMERICSERV
-                        0))
-       (lambda (ai1 ai2)
-         (equal? (addrinfo:addr ai1) (addrinfo:addr ai2))))))
+  (define uri
+    (ensure-uri-reference uri-or-string))
   (define https?
     (eq? 'https (uri-scheme uri)))
+
   (define (open-socket)
+    (define http-proxy
+      (if https? (current-https-proxy) (current-http-proxy)))
+    (define uri (ensure-uri-reference (or http-proxy uri-or-string)))
+    (define addresses
+      (let ((port (uri-port uri)))
+        (delete-duplicates
+         (getaddrinfo (uri-host uri)
+                      (cond (port => number->string)
+                            ((uri-scheme uri) => symbol->string)
+                            (else (error "Not an absolute URI" uri)))
+                      (if port
+                          AI_NUMERICSERV
+                          0))
+         (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))
@@ -199,29 +225,16 @@ host name without trailing dot."
                 (apply throw args)
                 (loop (cdr addresses))))))))
 
-  (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?
-                              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~%"))
-                           (thunk))
-                         (thunk)))))))
-    (with-https-proxy
-     (let ((s (open-socket)))
-       ;; Buffer input and output on this port.
-       (setvbuf s 'block %http-receive-buffer-size)
-
-       (if https?
-           (tls-wrap s (uri-host uri))
-           s)))))
+  (let ((s (open-socket)))
+    ;; Buffer input and output on this port.
+    (setvbuf s 'block %http-receive-buffer-size)
+
+    (when (and https? (current-https-proxy))
+      (setup-http-tunnel s uri))
+
+    (if https?
+        (tls-wrap s (uri-host uri))
+        s)))
 
 (define (extend-request r k v . additional)
   (let ((r (set-field r (request-headers)