[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Adding https support
From: |
Christopher Allan Webber |
Subject: |
Adding https support |
Date: |
Wed, 16 Sep 2015 18:01:03 -0500 |
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
>From 5df084b42bf6633af8107d6c994f7171afb04a84 Mon Sep 17 00:00:00 2001
From: Christopher Allan Webber <address@hidden>
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
+ ;; <http://bugs.gnu.org/18526> 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
- Adding https support,
Christopher Allan Webber <=