From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Christopher Allan Webber Newsgroups: gmane.lisp.guile.devel Subject: Adding https support Date: Wed, 16 Sep 2015 18:01:03 -0500 Message-ID: <87a8skbsiz.fsf@dustycloud.org> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1442528239 13456 80.91.229.3 (17 Sep 2015 22:17:19 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Thu, 17 Sep 2015 22:17:19 +0000 (UTC) To: guile-devel Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Fri Sep 18 00:17:00 2015 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1ZchUA-0005XQ-HW for guile-devel@m.gmane.org; Fri, 18 Sep 2015 00:16:58 +0200 Original-Received: from localhost ([::1]:33189 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZchU9-00013m-S5 for guile-devel@m.gmane.org; Thu, 17 Sep 2015 18:16:57 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:53081) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZchU6-00013d-A1 for guile-devel@gnu.org; Thu, 17 Sep 2015 18:16:55 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ZchU1-0006X8-Og for guile-devel@gnu.org; Thu, 17 Sep 2015 18:16:54 -0400 Original-Received: from dustycloud.org ([50.116.34.160]:51515) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZchU1-0006Wn-Hy for guile-devel@gnu.org; Thu, 17 Sep 2015 18:16:49 -0400 Original-Received: from earlgrey (localhost [127.0.0.1]) by dustycloud.org (Postfix) with ESMTPS id 40237228612 for ; Thu, 17 Sep 2015 18:16:47 -0400 (EDT) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 50.116.34.160 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:17841 Archived-At: --=-=-= Content-Type: text/plain Hello! So, Guile currently lacks https support, which I think is... strange in the present day! I've currently hit a limit with what I can do in implementing federation tools using Guile without https support. Luckily, I was pointed to Guix's guix/build/download.scm containing https support. Ludovic said he'd be fine with having his https-supporting code in Guile core and under the LGPL, and I offered to port it. The good news: I have it working locally separated from Guix. Attached is a patch with the current state of things. It isn't done though! There are remaining issues: - The tls file descriptor leak bug from Guix has been carried over here http://debbugs.gnu.org/cgi/bugreport.cgi?bug=20145 but I don't really know enough to know what I'm supposed to fix. Pointers? - open-socket-for-uri and open-connection-for-uri should be merged together. - needs a better commit message, I'll get to it! - I probably need to sign papers... I've signed them for other GNU projects but I think I haven't signed any kind of across-the-board GNU copyright assignment thing. Thoughts? - Chris --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0001-Preliminary-but-mostly-working-addition-of-https-sup.patch >From 5df084b42bf6633af8107d6c994f7171afb04a84 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Thu, 17 Sep 2015 15:14:54 -0500 Subject: [PATCH] Preliminary but mostly-working addition of https support to guile --- module/web/client.scm | 108 +++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 107 insertions(+), 1 deletion(-) diff --git a/module/web/client.scm b/module/web/client.scm index 070b0c3..4159f73 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 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 @@ -45,6 +45,7 @@ #:use-module (srfi srfi-9 gnu) #:export (current-http-proxy open-socket-for-uri + open-connection-for-uri http-get http-get* http-head @@ -54,11 +55,116 @@ 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 gnutls-module + (delay + (catch 'misc-error + (lambda () + (resolve-interface '(gnutls))) + (lambda _ + (format (current-error-port) + "warning: (gnutls) module not available\n") + #f)))) + +(define (ensure-gnutls) + (if (not (force gnutls-module)) + (error "(gnutls) module not available"))) + +(define (gnutls-ref symbol) + "Fetch method-symbol from the gnutls module" + (ensure-gnutls) + (module-ref (force gnutls-module) symbol)) + (define current-http-proxy (make-parameter (let ((proxy (getenv "http_proxy"))) (and (not (equal? proxy "")) proxy)))) +(define add-weak-reference + (let ((table (make-weak-key-hash-table))) + (lambda (from to) + "Hold a weak reference from FROM to TO." + (hashq-set! table from to)))) + +(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) + ((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))) + ;; Since we use `fileno' above, the file descriptor behind PORT would be + ;; closed when PORT is GC'd. If we used `port->fdes', it would instead + ;; never be closed. So we use `fileno', but keep a weak reference to + ;; PORT, so the file descriptor gets closed when RECORD is GC'd. + (add-weak-reference record port) + record))) + +(define (open-connection-for-uri uri) + "Like 'open-socket-for-uri', but also handle HTTPS connections." + (define https? + (eq? 'https (uri-scheme uri))) + + (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-for-uri uri))) + ;; Buffer input and output on this port. + (setvbuf s _IOFBF %http-receive-buffer-size) + + (if https? + (tls-wrap s (uri-host uri)) + s))))) + (define (ensure-uri uri-or-string) (cond ((string? uri-or-string) (string->uri uri-or-string)) -- 2.1.4 --=-=-=--