From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Christopher Allan Webber Newsgroups: gmane.lisp.guile.bugs Subject: bug#24075: tls/https support in Guile (through r6rs binary ports?) Date: Sun, 06 Nov 2016 11:37:45 -0600 Message-ID: <87lgww5x1y.fsf@dustycloud.org> References: <8760rss8al.fsf@dustycloud.org> <87a8gstgn6.fsf@pobox.com> <878tvqqfkq.fsf@dustycloud.org> <87r36p6aaz.fsf@dustycloud.org> <87fun56987.fsf@gnu.org> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: blaine.gmane.org 1478453940 19956 195.159.176.226 (6 Nov 2016 17:39:00 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Sun, 6 Nov 2016 17:39:00 +0000 (UTC) User-Agent: mu4e 0.9.16; emacs 25.1.1 Cc: 24075@debbugs.gnu.org To: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-X-From: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Sun Nov 06 18:38:53 2016 Return-path: Envelope-to: guile-bugs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1c3ROX-0007tM-U0 for guile-bugs@m.gmane.org; Sun, 06 Nov 2016 18:38:14 +0100 Original-Received: from localhost ([::1]:45689 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1c3ROa-0003qK-SG for guile-bugs@m.gmane.org; Sun, 06 Nov 2016 12:38:16 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:49791) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1c3ROQ-0003os-Rh for bug-guile@gnu.org; Sun, 06 Nov 2016 12:38:08 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1c3ROM-0006Z0-Sy for bug-guile@gnu.org; Sun, 06 Nov 2016 12:38:06 -0500 Original-Received: from debbugs.gnu.org ([208.118.235.43]:59936) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1c3ROM-0006Yg-PL for bug-guile@gnu.org; Sun, 06 Nov 2016 12:38:02 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1c3ROM-0001RB-GZ for bug-guile@gnu.org; Sun, 06 Nov 2016 12:38:02 -0500 X-Loop: help-debbugs@gnu.org Resent-From: Christopher Allan Webber Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Sun, 06 Nov 2016 17:38:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 24075 X-GNU-PR-Package: guile X-GNU-PR-Keywords: Original-Received: via spool by 24075-submit@debbugs.gnu.org id=B24075.14784538705506 (code B ref 24075); Sun, 06 Nov 2016 17:38:02 +0000 Original-Received: (at 24075) by debbugs.gnu.org; 6 Nov 2016 17:37:50 +0000 Original-Received: from localhost ([127.0.0.1]:47102 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1c3RO9-0001Qj-U2 for submit@debbugs.gnu.org; Sun, 06 Nov 2016 12:37:50 -0500 Original-Received: from dustycloud.org ([50.116.34.160]:46786) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1c3RO7-0001Qb-P8 for 24075@debbugs.gnu.org; Sun, 06 Nov 2016 12:37:48 -0500 Original-Received: from oolong (localhost [127.0.0.1]) by dustycloud.org (Postfix) with ESMTPS id 25F96265F2; Sun, 6 Nov 2016 12:37:46 -0500 (EST) In-reply-to: <87fun56987.fsf@gnu.org> X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: bug-guile@gnu.org List-Id: "Bug reports for GUILE, GNU's Ubiquitous Extension Language" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Original-Sender: "bug-guile" Xref: news.gmane.org gmane.lisp.guile.bugs:8449 Archived-At: --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: 8bit Ludovic Courtès writes: >> +(define (ensure-gnutls) >> + (if (not (force gnutls-module)) >> + (throw 'gnutls-not-available "(gnutls) module not available"))) > > I wonder if this is the right exception, but I can’t think of anything > better (there’s no generic “not supported” exception I think; (throw > 'system-error … ENOSYS) would do that but it’s too vague.) I don't know... it's hard for me to tell when to use what exception symbol in Guile! I prefer specific exceptions when a more general exception can't be found appropriately... at lest you'll catch the right one if you try to catch it in such a case. I also like that the above exception helps the user realize what isn't installed so they can resolve it. But if someone defines something concrete they'd prefer we can switch to that. >> +(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)))) > > What about leaving the ‘ensure-gnutls’ call and then simply use the > GnuTLS symbols directly and rely on autoloading, as in (guix build > download)? > > --8<---------------cut here---------------start------------->8--- > ;; Autoload GnuTLS so that this module can be used even when GnuTLS is > ;; not available. At compile time, this yields "possibly unbound > ;; variable" warnings, but these are OK: we know that the variables will > ;; be bound if we need them, because (guix download) adds GnuTLS as an > ;; input in that case. > > ;; XXX: Use this hack instead of #:autoload to avoid compilation errors. > ;; See . > (module-autoload! (current-module) > '(gnutls) '(make-session connection-end/client)) > --8<---------------cut here---------------end--------------->8--- > > That would lead more concise and slightly more efficient code, and I > think it would still work as expected in the absence of (gnutls). > > WDYT? So there was this converstaion on #guile: mark_weaver: the autoload hack fails gracelessly when GnuTLS is missing that's fine in the context of Guix, but maybe not in a more general context oh :) civodul: what approach would you suggest then? civodul: could we make it more graceful? yeah maybe with some explicit module hackery an explicit resolve-interface + module-ref something like that sounds doable So... that's what lead me to change it. Admittedly I'm not totally clear what was meant by "the autoload hack fails gracelessly", and what would be more graceful. Would it be because it's trying to utilize a symbol that's not bound to anything? Which leads to the next question: if I did the autoload hack, what would (ensure-gnutls) look like? I think it's not nice to throw an exception that the symbol is simply not in the current environment; that's not helpful for a user. (We'll still need to ensure that gnutls-version resolves to a procedure anyway, given the bug I added the comment about.) >> + (define (read! bv start count) >> + (define read-bv (get-bytevector-n record count)) >> + (define read-bv-len (bytevector-length read-bv)) >> + (bytevector-copy! read-bv 0 bv 0 read-bv-len) >> + read-bv-len) > > Beware: ‘get-bytevector-n’ can return the EOF object instead of a > number, so you need to check for that. (Conversely, ‘read!’ needs to > return 0 to indicate EOF.) So that would look like this? (define (read! bv start count) (define read-bv (get-bytevector-n record count)) (if (eof-object? read-bv) 0 (let ((read-bv-len (bytevector-length read-bv))) (bytevector-copy! read-bv 0 bv 0 read-bv-len) read-bv-len))) >> + (define (open-socket) >> + (let loop ((addresses addresses)) > > Or just “(define sock …”. Hm, is that a good idea? Does this need to happen before or within the with-https-proxy? > Otherwise works for me! > > Could you document HTTPS support in the doc of ‘open-socket-for-uri’ > (info "(guile) Web Client")? Probably with something like: > > @xref{Guile Preparations, > how to install the GnuTLS bindings for Guile,, gnutls-guile, > GnuTLS-Guile}, for more information. Done. > Thank you Chris! > > Ludo’. Updated patch attached. Still needs advisement on the exception and autoload bits though! - Chris --=-=-= Content-Type: text/x-patch Content-Disposition: inline; filename=0001-web-Add-https-support-through-gnutls.patch >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 --=-=-=--