From 91c0a4a728ca4bf2e9468cdc849c350dd3f7380f Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Thu, 17 Sep 2015 15:14:54 -0500 Subject: [PATCH] web: Add https support through gnutls. Since importing gnutls directly would result in a dependency cycle, we load gnutls lazily. This uses code originally written for Guix by Ludovic * module/web/client.scm: (%http-receive-buffer-size) (warn-no-gnutls-return-false, gnutls-module, ensure-gnutls) (gnutls-ref, tls-wrap): New variables. (open-socket-for-uri): Wrap in tls when uri scheme is https. * doc/ref/web.texi (open-socket-for-uri): Document gnutls usage. --- doc/ref/web.texi | 6 +- module/web/client.scm | 175 +++++++++++++++++++++++++++++++++++++++++++------- 2 files changed, 158 insertions(+), 23 deletions(-) diff --git a/doc/ref/web.texi b/doc/ref/web.texi index becdc28..c2f3f61 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -1422,7 +1422,11 @@ the lower-level HTTP, request, and response modules. @end example @deffn {Scheme Procedure} open-socket-for-uri uri -Return an open input/output port for a connection to URI. +Return an open input/output port for a connection to URI. Guile +dynamically loads gnutls for https support; for more information, see +@xref{Guile Preparations, +how to install the GnuTLS bindings for Guile,, gnutls-guile, +GnuTLS-Guile}. @end deffn @deffn {Scheme Procedure} http-get uri arg... diff --git a/module/web/client.scm b/module/web/client.scm index f24a4d7..f0fba49 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -1,6 +1,6 @@ ;;; Web client -;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2012, 2013, 2014, 2015, 2016 Free Software Foundation, Inc. ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -43,8 +43,11 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module ((rnrs io ports) + #:prefix rnrs-ports:) #:export (current-http-proxy open-socket-for-uri + open-connection-for-uri http-get http-get* http-head @@ -54,11 +57,113 @@ http-trace http-options)) +(define %http-receive-buffer-size + ;; Size of the HTTP receive buffer. + 65536) + +;; Provide access to the gnutls-module, but fail gracefully if not available. +;; Why take this route and not just straight up import the module? +;; Guile can't depend on gnutls because gnutls includes Guile as a dependency. +;; There's some risk of dependency cycles, so lazily resolving things only +;; once needed helps! + +(define warn-no-gnutls-return-false + (lambda _ + (format (current-error-port) + "warning: (gnutls) module not available\n") + #f)) + +(define gnutls-module + (delay + (catch 'misc-error + (lambda () + (let ((module (resolve-interface '(gnutls)))) + ;; In some 2.1/2.2 installations installed alongside Guile 2.0, gnutls + ;; can be imported but the bindings are broken as "unknown type". + ;; Here we check that gnutls-version is the right type (a procedure) + ;; to make sure the bindings are ok. + (if (procedure? (module-ref module 'gnutls-version)) + module + (warn-no-gnutls-return-false)))) + warn-no-gnutls-return-false))) + +(define (ensure-gnutls) + (if (not (force gnutls-module)) + (throw 'gnutls-not-available "(gnutls) module not available"))) + +(define (gnutls-ref symbol) + "Fetch method-symbol from the gnutls module" + (module-ref (force gnutls-module) symbol)) + (define current-http-proxy (make-parameter (let ((proxy (getenv "http_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." + (define (log level str) + (format (current-error-port) + "gnutls: [~a|~a] ~a" (getpid) level str)) + + (ensure-gnutls) + + (let ((session ((gnutls-ref 'make-session) + (gnutls-ref 'connection-end/client)))) + + ;; Some servers such as 'cloud.github.com' require the client to support + ;; the 'SERVER NAME' extension. However, 'set-session-server-name!' is + ;; not available in older GnuTLS releases. See + ;; for details. + (if (module-defined? (force gnutls-module) + 'set-session-server-name!) + ((gnutls-ref 'set-session-server-name!) + session (gnutls-ref 'server-name-type/dns) server) + (format (current-error-port) + "warning: TLS 'SERVER NAME' extension not supported~%")) + + ((gnutls-ref 'set-session-transport-fd!) session (fileno port)) + ((gnutls-ref 'set-session-default-priority!) session) + + ;; The "%COMPAT" bit allows us to work around firewall issues (info + ;; "(gnutls) Priority Strings"); see . + ;; Explicitly disable SSLv3, which is insecure: + ;; . + ((gnutls-ref 'set-session-priorities!) session "NORMAL:%COMPAT:-VERS-SSL3.0") + + ((gnutls-ref 'set-session-credentials!) session + ((gnutls-ref 'make-certificate-credentials))) + + ;; Uncomment the following lines in case of debugging emergency. + ;;(set-log-level! 10) + ;;(set-log-procedure! log) + + ((gnutls-ref 'handshake) session) + (let ((record ((gnutls-ref 'session-record-port) session))) + (define (read! bv start count) + (define read-bv (get-bytevector-n record count)) + (if (eof-object? read-bv) + 0 ; read! returns 0 on eof-object + (let ((read-bv-len (bytevector-length read-bv))) + (bytevector-copy! read-bv 0 bv 0 read-bv-len) + read-bv-len))) + (define (write! bv start count) + (put-bytevector record bv start count) + count) + (define (get-position) + (rnrs-ports:port-position record)) + (define (set-position! new-position) + (rnrs-ports:set-port-position! record new-position)) + (define (close) + (unless (port-closed? port) + (close-port port)) + (unless (port-closed? record) + (close-port record))) + (make-custom-binary-input/output-port "gnutls wrapped port" read! write! + get-position set-position! + close)))) + (define (ensure-uri uri-or-string) (cond ((string? uri-or-string) (string->uri uri-or-string)) @@ -81,27 +186,53 @@ 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)) - ;; 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 'block) - ;; If we're using a proxy, make a note of that. - (when http-proxy (set-http-proxy-port?! s #t)) - s) - (lambda args - ;; Connection failed, so try one of the other addresses. - (close s) - (if (null? (cdr addresses)) - (apply throw args) - (loop (cdr addresses)))))))) + (define https? + (eq? 'https (uri-scheme uri))) + (define (open-socket) + (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 'block) + ;; If we're using a proxy, make a note of that. + (when http-proxy (set-http-proxy-port?! s #t)) + s) + (lambda args + ;; Connection failed, so try one of the other addresses. + (close s) + (if (null? (cdr addresses)) + (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 _IOFBF %http-receive-buffer-size) + + (if https? + (tls-wrap s (uri-host uri)) + s))))) (define (extend-request r k v . additional) (let ((r (set-field r (request-headers) -- 2.10.2