bug#24075: tls/https support in Guile (through r6rs binary ports?)

[Christopher Allan Webber]

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 <http://bugs.gnu.org/12202>.
> (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:

  <civodul> mark_weaver: the autoload hack fails gracelessly when GnuTLS is     
  
            missing
  <civodul> that's fine in the context of Guix, but maybe not in a more general 
  
            context
  <paron_remote> oh :)
  <paron_remote> civodul: what approach would you suggest then?
  <mark_weaver> civodul: could we make it more graceful?
  <civodul> yeah maybe with some explicit module hackery
  <civodul> an explicit resolve-interface + module-ref
  <civodul> something like that
  <mark_weaver> 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

>From 91c0a4a728ca4bf2e9468cdc849c350dd3f7380f Mon Sep 17 00:00:00 2001
From: Christopher Allan Webber <address@hidden>
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
address@hidden 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
+    ;; <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)
+
+    ;; The "%COMPAT" bit allows us to work around firewall issues (info
+    ;; "(gnutls) Priority Strings"); see <http://bugs.gnu.org/23311>.
+    ;; Explicitly disable SSLv3, which is insecure:
+    ;; <https://tools.ietf.org/html/rfc7568>.
+    ((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