Re: ALPN support for GnuTLS connections

[Robert Pluim <rpluim@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 764 bytes --]

>>>>> On Mon, 07 Oct 2024 10:22:25 +0200, Robert Pluim <rpluim@gmail.com> said:

>>>>> On Mon, 30 Sep 2024 19:26:54 +0200, Eric Marsden <eric.marsden@risk-engineering.org> said:
    Eric> On 30/09/2024 15:13, Robert Pluim wrote:
    >>> The existing code in `gnutls-boot' already does very similar things
    >>> for other parameters. If I propose a patch, could you test it? I
    >>> should be able to have something by the end of the week.

    Eric> Sure, I would be glad to test a patch.

    Robert> The code is written but not tested fully, and since Iʼve been sick the
    Robert> past few days I havenʼt been able to complete it. Hopefully Iʼll get
    Robert> to it by the end of this week.

Patch below. Works in my limited testing.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Add-support-for-GnuTLS-ALPN-negotiation.patch --]
[-- Type: text/x-diff, Size: 8447 bytes --]

From 9ec71754d4c7b593772fa336101e189b6a0ff962 Mon Sep 17 00:00:00 2001
From: Robert Pluim <rpluim@gmail.com>
Date: Thu, 10 Oct 2024 15:48:49 +0200
Subject: [PATCH] Add support for GnuTLS ALPN negotiation
To: emacs-devel@gnu.org

* lisp/net/gnutls.el (open-gnutls-stream): Pass unrecognized
parameters down to gnutls-boot.
(gnutls-negotiate): Add :alpn-protocols keyword.
(gnutls-boot-parameters): Add :alpn-protocols keyword.
* src/gnutls.c [GNUTLS_VERSION_NUMBER >= 0x030200] : Define
HAVE_GNUTLS_ALPN_SET_PROTOCOLS.
(Fgnutls_boot) [HAVE_GNUTLS_ALPN_SET_PROTOCOLS]: Add
:alpn-protocols keyword.  Pass any string values to
gnutls_alpn_set_protocols.
(syms_of_gnutls): Add QCalpn_protocols symbol.
---
 lisp/net/gnutls.el | 38 ++++++++++++++++++++++++++++----------
 src/gnutls.c       | 43 +++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 71 insertions(+), 10 deletions(-)

diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el
index b5fb4d47d57..dc9870136d6 100644
--- a/lisp/net/gnutls.el
+++ b/lisp/net/gnutls.el
@@ -168,7 +168,9 @@ open-gnutls-stream
 Fifth arg PARAMETERS is an optional list of keyword/value pairs.
 Only :client-certificate, :nowait, and :coding keywords are
 recognized, and have the same meaning as for
-`open-network-stream'.
+`open-network-stream'.  Any other keyword arguments are presumed to be
+TLS-specific parameters, and are passed down to `gnutls-boot'
+unmodified.
 For historical reasons PARAMETERS can also be a symbol, which is
 interpreted the same as passing a list containing :nowait and the
 value of that symbol.
@@ -197,23 +199,32 @@ open-gnutls-stream
          (cert (network-stream-certificate host service parameters))
          (keylist (and cert (list cert)))
          (nowait (plist-get parameters :nowait))
+         (tls-parameters (apply #'append
+                                (cl-remove-if
+                                 (lambda (elt)
+                                   (memq (car elt)
+                                         '(:client-certificate :nowait :coding)))
+                                 (seq-split parameters 2))))
          (process (open-network-stream
                    name buffer host service
                    :nowait nowait
                    :tls-parameters
                    (and nowait
                         (cons 'gnutls-x509pki
-                              (gnutls-boot-parameters
-                               :type 'gnutls-x509pki
-                               :keylist keylist
-                               :hostname (puny-encode-domain host))))
+                              (apply #'gnutls-boot-parameters
+                                     :type 'gnutls-x509pki
+                                     :keylist keylist
+                                     :hostname (puny-encode-domain host)
+                                     tls-parameters)))
                    :coding (plist-get parameters :coding))))
     (if nowait
         process
-      (gnutls-negotiate :process process
-                        :type 'gnutls-x509pki
-                        :keylist keylist
-                        :hostname (puny-encode-domain host)))))
+      (apply #'gnutls-negotiate
+             :process process
+             :type 'gnutls-x509pki
+             :keylist keylist
+             :hostname (puny-encode-domain host)
+             tls-parameters))))
 
 (define-error 'gnutls-error "GnuTLS error")
 
@@ -226,6 +237,7 @@ gnutls-negotiate
            &key process type hostname priority-string
            trustfiles crlfiles keylist min-prime-bits
            verify-flags verify-error verify-hostname-error
+           alpn-protocols
            &allow-other-keys)
   "Negotiate a SSL/TLS connection.  Return proc.  Signal gnutls-error.
 
@@ -241,6 +253,7 @@ gnutls-negotiate
                   :type type
                   :hostname hostname
                   :priority-string priority-string
+                  :alpn-protocols alpn-protocols
                   :trustfiles trustfiles
                   :crlfiles crlfiles
                   :keylist keylist
@@ -266,7 +279,7 @@ gnutls-boot-parameters
            &key type hostname priority-string
            trustfiles crlfiles keylist min-prime-bits
            verify-flags verify-error verify-hostname-error
-           pass flags
+           pass flags alpn-protocols
            &allow-other-keys)
   "Return a keyword list of parameters suitable for passing to `gnutls-boot'.
 
@@ -290,6 +303,10 @@ gnutls-boot-parameters
 bitflag of the gnutls_pkcs_encrypt_flags_t enum of GnuTLS.  The
 empty list corresponds to the bitflag with value 0.
 
+ALPN-PROTOCOLS is a list of strings to be offered as protocols in ALPN
+negotiation.  Note that failure to negotiate a protocol is not treated
+as a fatal error by Emacs.
+
 When VERIFY-ERROR is t or a list containing `:trustfiles', an
 error will be raised when the peer certificate verification fails
 as per GnuTLS' gnutls_certificate_verify_peers2.  Otherwise, only
@@ -359,6 +376,7 @@ gnutls-boot-parameters
          (push :hostname verify-error))
 
     `(:priority ,priority-string
+                :alpn-protocols ,alpn-protocols
                 :hostname ,hostname
                 :loglevel ,gnutls-log-level
                 :min-prime-bits ,min-prime-bits
diff --git a/src/gnutls.c b/src/gnutls.c
index 334d1d47eb6..0360d9cb740 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -36,6 +36,7 @@
 # if GNUTLS_VERSION_NUMBER >= 0x030200
 #  define HAVE_GNUTLS_CERTIFICATE_SET_X509_KEY_FILE2
 #  define HAVE_GNUTLS_CIPHER_GET_IV_SIZE
+#  define HAVE_GNUTLS_ALPN_SET_PROTOCOLS
 # endif
 
 # if GNUTLS_VERSION_NUMBER >= 0x030202
@@ -1900,6 +1901,10 @@ DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
 
 :priority is a GnuTLS priority string, defaults to "NORMAL".
 
+:alpn-protocols is a list of strings to use for ALPN negotiation.
+Failing to agree on an ALPN protocol is not treated as a fatal error by
+Emacs.
+
 :trustfiles is a list of PEM-encoded trust files for `gnutls-x509pki'.
 
 :crlfiles is a list of PEM-encoded CRL lists for `gnutls-x509pki'.
@@ -1979,6 +1984,7 @@ DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
 
   /* Placeholders for the property list elements.  */
   Lisp_Object priority_string;
+  Lisp_Object alpn_protocols;
   Lisp_Object trustfiles;
   Lisp_Object crlfiles;
   Lisp_Object keylist;
@@ -2011,6 +2017,7 @@ DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
 
   hostname              = plist_get (proplist, QChostname);
   priority_string       = plist_get (proplist, QCpriority);
+  alpn_protocols        = plist_get (proplist, QCalpn_protocols);
   trustfiles            = plist_get (proplist, QCtrustfiles);
   keylist               = plist_get (proplist, QCkeylist);
   crlfiles              = plist_get (proplist, QCcrlfiles);
@@ -2251,6 +2258,41 @@ DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
 
   GNUTLS_INITSTAGE (proc) = GNUTLS_STAGE_PRIORITY;
 
+#ifdef HAVE_GNUTLS_ALPN_SET_PROTOCOLS
+  if (!NILP (alpn_protocols))
+    {
+      Lisp_Object length = Fproper_list_p (alpn_protocols);
+      if (!NILP (length))
+	{
+	  int count = XFIXNAT (length);
+	  gnutls_datum_t *protocols = xzalloc (count * sizeof (gnutls_datum_t));
+	  count = 0;
+	  GNUTLS_LOG (1, max_log_level, "setting ALPN protocols");
+	  for (Lisp_Object tail = alpn_protocols; CONSP (tail); tail = XCDR (tail))
+	    {
+	      Lisp_Object proto = XCAR (tail);
+	      if (STRINGP (proto))
+		{
+		  protocols[count].data = SDATA (proto);
+		  protocols[count].size = strlen (SSDATA (proto));
+		  count++;
+		}
+	    }
+	  int ret = 0;
+	  if (count)
+	    ret = gnutls_alpn_set_protocols (state, protocols, count, 0);
+
+	  /* gnutls_alpn_set_protocols copies the protocol strings, so
+	     we can free it here.  */
+	  xfree (protocols);
+	  if (ret < GNUTLS_E_SUCCESS)
+	    return gnutls_make_error (ret);
+
+	  GNUTLS_LOG (1, max_log_level, "ALPN protocols set");
+	}
+    }
+#endif
+
   if (FIXNUMP (prime_bits))
     gnutls_dh_set_prime_bits (state, XUFIXNUM (prime_bits));
 
@@ -3020,6 +3062,7 @@ syms_of_gnutls (void)
   /* The following are for the property list of 'gnutls-boot'.  */
   DEFSYM (QChostname, ":hostname");
   DEFSYM (QCpriority, ":priority");
+  DEFSYM (QCalpn_protocols, ":alpn-protocols");
   DEFSYM (QCtrustfiles, ":trustfiles");
   DEFSYM (QCkeylist, ":keylist");
   DEFSYM (QCcrlfiles, ":crlfiles");
-- 
2.39.5