From 8cc19d6bb5e7d1eb38faf84e92ecbd52a7394ea1 Mon Sep 17 00:00:00 2001
From: Christopher Allan Webber <cwebber@dustycloud.org>
Date: Thu, 17 Sep 2015 15:14:54 -0500
Subject: [PATCH] Perliminary but mostly-working addition of https support to
 guile

---
 module/web/client.scm | 103 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 103 insertions(+)

diff --git a/module/web/client.scm b/module/web/client.scm
index 070b0c3..f5a52ec 100644
--- a/module/web/client.scm
+++ b/module/web/client.scm
@@ -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,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.
+(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))))
+
+;; TODO: error out early if gnutls not available
+
+(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