diff options
-rw-r--r-- | doc/ref/web.texi | 7 | ||||
-rw-r--r-- | 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 c642d0484..91b3a4edf 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 874b04d0a..3761eb546 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) |