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: Sat, 05 Nov 2016 13:39:16 -0500 Message-ID: <87r36p6aaz.fsf@dustycloud.org> References: <8760rss8al.fsf@dustycloud.org> <87a8gstgn6.fsf@pobox.com> <878tvqqfkq.fsf@dustycloud.org> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: blaine.gmane.org 1478371241 15821 195.159.176.226 (5 Nov 2016 18:40:41 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Sat, 5 Nov 2016 18:40:41 +0000 (UTC) User-Agent: mu4e 0.9.16; emacs 25.1.1 Cc: 24075@debbugs.gnu.org To: Andy Wingo Original-X-From: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Sat Nov 05 19:40:36 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 1c35sy-0000Uk-RY for guile-bugs@m.gmane.org; Sat, 05 Nov 2016 19:40:13 +0100 Original-Received: from localhost ([::1]:54790 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1c35t1-00080W-M6 for guile-bugs@m.gmane.org; Sat, 05 Nov 2016 14:40:15 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:41279) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1c35ss-0007xD-PI for bug-guile@gnu.org; Sat, 05 Nov 2016 14:40:10 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1c35so-0000wX-Uv for bug-guile@gnu.org; Sat, 05 Nov 2016 14:40:06 -0400 Original-Received: from debbugs.gnu.org ([208.118.235.43]:58958) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1c35so-0000wI-Pj for bug-guile@gnu.org; Sat, 05 Nov 2016 14:40:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1c35so-0002MF-KG for bug-guile@gnu.org; Sat, 05 Nov 2016 14:40:02 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Christopher Allan Webber Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Sat, 05 Nov 2016 18:40: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.14783711609006 (code B ref 24075); Sat, 05 Nov 2016 18:40:02 +0000 Original-Received: (at 24075) by debbugs.gnu.org; 5 Nov 2016 18:39:20 +0000 Original-Received: from localhost ([127.0.0.1]:46124 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1c35s8-0002LC-6o for submit@debbugs.gnu.org; Sat, 05 Nov 2016 14:39:20 -0400 Original-Received: from dustycloud.org ([50.116.34.160]:44584) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1c35s5-0002L4-Vi for 24075@debbugs.gnu.org; Sat, 05 Nov 2016 14:39:18 -0400 Original-Received: from oolong (localhost [127.0.0.1]) by dustycloud.org (Postfix) with ESMTPS id 4D1BE265F2; Sat, 5 Nov 2016 14:39:17 -0400 (EDT) In-reply-to: <878tvqqfkq.fsf@dustycloud.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:8446 Archived-At: --=-=-= Content-Type: text/plain Christopher Allan Webber writes: > Here's two patches. The first fixes some of the section names in the > r6rs-ports.test file, and can be applied to master immediately. I don't think it was captured, but these patches were applied to master. So the next thing is getting the gnutls support for https in Guile. And! I have a patch that does that! I think it's probably good enough to be merged probably at this point, but it could use review. --=-=-= Content-Type: text/x-patch Content-Disposition: inline; filename=0001-web-Add-https-support-through-gnutls.patch >From d4def07779c5532ffc6b7ee13820919bc23d1811 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. --- module/web/client.scm | 173 +++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 151 insertions(+), 22 deletions(-) diff --git a/module/web/client.scm b/module/web/client.scm index f24a4d7..f1a6bb5 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,111 @@ 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)) + (define 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 +184,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 --=-=-=--