Re: GnuTLS server support?

["J.P." <jp@neverwas.me>]

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

Ted Zlatanov <tzz@lifelogs.com> writes:

> On Fri, 17 Sep 2021 08:40:06 +0000 Qiantan Hong <qhong@mit.edu> wrote: 
>
> QH> It seems that currently Emacs can act as a TLS client,
> QH> not a server. 
> QH> This makes it impossible to have secure connection between Emacsen.
>
> QH> Anyone have an idea how much effort will make it works?
>
> I think it would be useful and worthwhile to implement a GnuTLS server
> inside Emacs.
>
> Ted

Hi Qiantan (and Ted),

Just wondering if there's been any progress on this front.

ERC, for one, stands to benefit from such a feature, both in our
client-to-client module and in our behavioral tests. As for the latter,
I've been running our suite with a simplistic sketch of this feature for
a little bit now (externally, of course). FWIW, it's already caught one
elusive bug.

I've included said sketch below in hopes of getting the wheels turning
in the minds of you experts (if only as a repugnant reminder of what not
to do).

Thanks,
J.P.

P.S. Would someone be willing to open a bug report for this feature (I
guess it'd fall under "wishlist")?


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-POC-Add-TLS-for-network-server-processes.patch --]
[-- Type: text/x-patch, Size: 12154 bytes --]

From 3d4850897109c96c07f26dcfe9001a0c6e4aa074 Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Mon, 9 May 2022 00:35:40 -0700
Subject: [PATCH] [POC] Add TLS for network server processes

WARNING: No DTLS, no caching (session IDs), no authentication.

* src/gnutls.c (gnutls_certificate_server_set_request): Use another
gnutls shared library function.
(gnutls_verify_boot): In server mode, skip verification when the
client did not send a cert.
(gnutls-boot): For now, tell `gnutls_certificate_server_set_request'
to always request but not require a client cert.  Use fictitious boot
parameter `:server' to detect whether this is an incoming client
connection being served.  This can always be made official at some
point by adding a `:server' param to `gnutls-negotiate' and friends.

* src/process.c (make-network-process): Allow caller to specify
`:tls-parameters' when creating a server, but don't store them in the
gnutls_boot_parameters field of the Lisp_Process object.
(server_accept_connection): Set Lisp_Process.gnutls_boot_parameters
field of accepted connections to original `:tls-parameters' value
passed to `make-network-process' when creating the server.

* test/lisp/net/network-stream-tests.el (make-tls-server,
make-tls-server--gnutls-serv, make-tls-server--emacs): Add variant for
existing TLS-server helper that uses another Emacs instead of the
external gnutls-serv command-line utility.
(open-network-stream-tls-client-cert): Add test that checks for
a client cert from the server's perspective.
---
 src/gnutls.c                          | 18 ++++-
 src/process.c                         | 25 ++++++-
 test/lisp/net/network-stream-tests.el | 98 ++++++++++++++++++++++++++-
 3 files changed, 136 insertions(+), 5 deletions(-)

diff --git a/src/gnutls.c b/src/gnutls.c
index 0e1e63e157..ba464f5548 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -311,6 +311,7 @@ init_gnutls_functions (void)
   LOAD_DLL_FN (library, gnutls_certificate_allocate_credentials);
   LOAD_DLL_FN (library, gnutls_certificate_free_credentials);
   LOAD_DLL_FN (library, gnutls_certificate_get_peers);
+  LOAD_DLL_FN (library, gnutls_certificate_server_set_request);
   LOAD_DLL_FN (library, gnutls_certificate_set_verify_flags);
   LOAD_DLL_FN (library, gnutls_certificate_set_x509_crl_file);
   LOAD_DLL_FN (library, gnutls_certificate_set_x509_key_file);
@@ -452,6 +453,7 @@ init_gnutls_functions (void)
 #  define gnutls_certificate_allocate_credentials fn_gnutls_certificate_allocate_credentials
 #  define gnutls_certificate_free_credentials fn_gnutls_certificate_free_credentials
 #  define gnutls_certificate_get_peers fn_gnutls_certificate_get_peers
+#  define gnutls_certificate_server_set_request fn_gnutls_certificate_server_set_request
 #  define gnutls_certificate_set_verify_flags fn_gnutls_certificate_set_verify_flags
 #  define gnutls_certificate_set_x509_crl_file fn_gnutls_certificate_set_x509_crl_file
 #  define gnutls_certificate_set_x509_key_file fn_gnutls_certificate_set_x509_key_file
@@ -1663,7 +1665,13 @@ gnutls_verify_boot (Lisp_Object proc, Lisp_Object proplist)
      gnutls_x509_crt_check_hostname against :hostname.  */
 
   ret = gnutls_certificate_verify_peers2 (state, &peer_verification);
-  if (ret < GNUTLS_E_SUCCESS)
+  if (ret == GNUTLS_E_NO_CERTIFICATE_FOUND
+      && !NILP (Fplist_get (proplist, QCserver)))
+    {
+      p->gnutls_p = true;
+      return Qt;
+    }
+  else if (ret < GNUTLS_E_SUCCESS)
     return gnutls_make_error (ret);
 
   p->gnutls_peer_verification = peer_verification;
@@ -1852,6 +1860,7 @@ DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
   Lisp_Object loglevel;
   Lisp_Object hostname;
   Lisp_Object prime_bits;
+  Lisp_Object server;
   struct Lisp_Process *p = XPROCESS (proc);
 
   CHECK_PROCESS (proc);
@@ -1877,6 +1886,7 @@ DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
   crlfiles              = Fplist_get (proplist, QCcrlfiles);
   loglevel              = Fplist_get (proplist, QCloglevel);
   prime_bits            = Fplist_get (proplist, QCmin_prime_bits);
+  server                = Fplist_get (proplist, QCserver);
 
   if (!STRINGP (hostname))
     {
@@ -2061,7 +2071,7 @@ DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
   /* Call gnutls_init here: */
 
   GNUTLS_LOG (1, max_log_level, "gnutls_init");
-  int gnutls_flags = GNUTLS_CLIENT;
+  int gnutls_flags = NILP (server) ? GNUTLS_CLIENT : GNUTLS_SERVER;
 # ifdef GNUTLS_NONBLOCK
   if (XPROCESS (proc)->is_non_blocking_client)
     gnutls_flags |= GNUTLS_NONBLOCK;
@@ -2100,7 +2110,9 @@ DEFUN ("gnutls-boot", Fgnutls_boot, Sgnutls_boot, 3, 3, 0,
   if (ret < GNUTLS_E_SUCCESS)
     return gnutls_make_error (ret);
 
-  if (!gnutls_ip_address_p (c_hostname))
+  if (!NILP (server))
+    gnutls_certificate_server_set_request (state, GNUTLS_CERT_REQUEST);
+  else if (!gnutls_ip_address_p (c_hostname))
     {
       ret = gnutls_server_name_set (state, GNUTLS_NAME_DNS, c_hostname,
 				    strlen (c_hostname));
diff --git a/src/process.c b/src/process.c
index 2f8863aef2..e0450fe950 100644
--- a/src/process.c
+++ b/src/process.c
@@ -4189,7 +4189,7 @@ DEFUN ("make-network-process", Fmake_network_process, Smake_network_process,
   eassert (! p->dns_request);
 #endif
 #ifdef HAVE_GNUTLS
-  tem = Fplist_get (contact, QCtls_parameters);
+  tem = NILP (server) ? Fplist_get (contact, QCtls_parameters) : Qnil;
   CHECK_LIST (tem);
   p->gnutls_boot_parameters = tem;
 #endif
@@ -5022,6 +5022,29 @@ server_accept_connection (Lisp_Object server, int channel)
   AUTO_STRING (nl, "\n");
   Lisp_Object host_string = STRINGP (host) ? host : dash;
 
+#ifdef HAVE_GNUTLS
+  // This currently only works with streams
+  p->gnutls_boot_parameters = Fplist_get (contact, QCtls_parameters);
+  if (!NILP (p->gnutls_boot_parameters))
+    {
+      Lisp_Object boot, params;
+      params = Fplist_put (XCDR (p->gnutls_boot_parameters), QCserver, Qt);
+      params = Fplist_put (params, QCcomplete_negotiation, Qt);
+      params = Fplist_put (params, QChostname, host_string);
+
+      boot = Fgnutls_boot (proc, XCAR (p->gnutls_boot_parameters), params);
+      if (p->gnutls_initstage != GNUTLS_STAGE_READY)
+	{
+	  deactivate_process (proc);
+	  pset_status (p, list2 (Qfailed, (NILP (boot))
+				 ? build_string ("TLS negotiation failed")
+				 : boot));
+	  return;
+	}
+      p->gnutls_boot_parameters = Qnil;
+    }
+#endif
+
   if (!NILP (ps->log))
     {
       AUTO_STRING (accept_from, "accept from ");
diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el
index 1bdc35da19..5395ebf7ea 100644
--- a/test/lisp/net/network-stream-tests.el
+++ b/test/lisp/net/network-stream-tests.el
@@ -243,7 +243,49 @@ echo-server-nowait
       (should (equal (buffer-string) "foo\n")))
     (delete-process server)))
 
-(defun make-tls-server (port)
+(defun network-stream-tests-serve-tls ()
+  (let ((h "<!DOCTYPE html><html><body><pre>%s\n\n%s\n</pre></body></html>")
+        (f (lambda (p m) (message "%s: %s" p (string-trim-right m))))
+        key cert port proc family http)
+    (while (pcase (pop command-line-args-left)
+             ("--x509keyfile" (setq key (pop command-line-args-left)))
+             ("--x509certfile" (setq cert (pop command-line-args-left)))
+             ("--http" (setq http t))
+             ("--6" (setq family 'ipv6))
+             ("--4" (setq family 'ipv4))
+             ("--port" (setq port (pop command-line-args-left)))
+             (_ (cl-assert (null command-line-args-left))
+                (cl-assert (and key cert port)))))
+    (setq proc
+          (make-network-process
+           :name "srv"
+           :server t
+           :noquery t
+           :buffer (get-buffer-create "*srv*")
+           :tls-parameters `(gnutls-x509pki :keylist ((,key ,cert)))
+           :filter (lambda (proc string)
+                     (process-send-string
+                      proc
+                      (if http
+                          (let ((nfo (list :contact (process-contact proc t)
+                                           :status (gnutls-peer-status proc))))
+                            (string-join
+                             (list "HTTP/1.0 200 OK" "Content-type: text/html"
+                                   "" (format h string nfo))
+                             "\r\n"))
+                        (concat "echo: " string)))
+                     (when http (delete-process proc)))
+           :log (lambda (_ proc msg) (funcall f proc msg))
+           :sentinel (lambda (proc event) (funcall f proc event))
+           :family family ; or AF_UNSPEC
+           :service port
+           :host "localhost"))
+    (message "listening on %s" (format-network-address
+                                (process-contact proc :local)))
+    (while (process-live-p proc)
+      (accept-process-output nil 0.1))))
+
+(defun make-tls-server--gnutls-serv (port)
   (start-process "gnutls" (generate-new-buffer "*tls*")
                  "gnutls-serv" "--http"
                  "--x509keyfile"
@@ -252,6 +294,39 @@ make-tls-server
                  (ert-resource-file "cert.pem")
                  "--port" (format "%s" port)))
 
+(defun make-tls-server--emacs (port)
+  (with-current-buffer
+      (process-buffer
+       (apply
+        #'start-process
+        `("gnutls" ,(generate-new-buffer "*tls*")
+          ,(concat invocation-directory invocation-name)
+          "-Q"
+          "-batch"
+          "-l" ,(expand-file-name "../network-stream-tests.el"
+                                  (ert-resource-directory))
+          "-f" "network-stream-tests-serve-tls"
+          "--http"
+          "--x509keyfile" ,(ert-resource-file "key.pem")
+          "--x509certfile" ,(ert-resource-file "cert.pem")
+          ;; Hmm, pcase complains about missing `rx--to-expr'
+          ,@(when (string-match
+                   (rx (| (group-n 4 "v4") (group-n 6 "v6")))
+                   (symbol-name (ert-test-name (ert-running-test))))
+              (cond ((match-beginning 4) (list "--4"))
+                    ((match-beginning 6) (list "--6"))))
+          "--port" ,(format "%s" port))))
+    (set-process-sentinel (get-buffer-process (current-buffer))
+                          (lambda (p _) (kill-buffer (process-buffer p))))
+    (while (progn (goto-char (point-min))
+                  (not (search-forward "listening on" nil t)))
+      (sleep-for 0.1))
+    (get-buffer-process (current-buffer))))
+
+(defalias 'make-tls-server (if (featurep 'make-network-process '(:server t))
+                               #'make-tls-server--emacs ; ifdef subprocesses
+                             #'make-tls-server--gnutls-serv))
+
 (ert-deftest connect-to-tls-ipv4-wait ()
   (skip-unless (executable-find "gnutls-serv"))
   (skip-unless (gnutls-available-p))
@@ -537,6 +612,27 @@ open-network-stream-tls-nocert
       (setq issuer (split-string issuer ","))
       (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))
 
+(ert-deftest open-network-stream-tls-client-cert ()
+  (skip-unless (executable-find "gnutls-serv"))
+  (skip-unless (gnutls-available-p))
+  (make-tls-server 44338)
+  (let* ((network-security-level 'low)
+         (proc (open-network-stream
+                "client-cert" (generate-new-buffer "*client-cert*")
+                "localhost" 44338
+                :type 'tls
+                :client-certificate (list (ert-resource-file "key.pem")
+                                          (ert-resource-file "cert.pem")))))
+    (process-send-string proc "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n")
+    (with-current-buffer (process-buffer proc)
+      (with-timeout (5 (ert-fail "Timed out"))
+        (while (save-excursion
+                 (goto-char (point-min))
+                 (not (search-forward "O=Emacs Test Servicess LLC" nil t)))
+          (accept-process-output proc 0.1))))
+    (delete-process proc)
+    (when noninteractive (kill-buffer (process-buffer proc)))))
+
 (ert-deftest open-gnutls-stream-new-api-default ()
   (skip-unless (executable-find "gnutls-serv"))
   (skip-unless (gnutls-available-p))
-- 
2.35.1