From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: "J.P." Newsgroups: gmane.emacs.devel Subject: Re: GnuTLS server support? Date: Wed, 11 May 2022 07:33:38 -0700 Message-ID: <878rr8xhod.fsf@neverwas.me> References: <3BC1A3EC-AB45-4E0D-A64B-6F3FE4C84C30@mit.edu> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="27821"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/29.0.50 (gnu/linux) Cc: emacs-devel@gnu.org, Ted Zlatanov To: Qiantan Hong Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Wed May 11 17:53:47 2022 Return-path: Envelope-to: ged-emacs-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1nooen-00071X-Qe for ged-emacs-devel@m.gmane-mx.org; Wed, 11 May 2022 17:53:45 +0200 Original-Received: from localhost ([::1]:44446 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1nooem-00061y-Cw for ged-emacs-devel@m.gmane-mx.org; Wed, 11 May 2022 11:53:44 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:47062) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1nonUK-0005s7-SR for emacs-devel@gnu.org; Wed, 11 May 2022 10:38:52 -0400 Original-Received: from mail-108-mta99.mxroute.com ([136.175.108.99]:43823) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1nonUI-0008SZ-D5 for emacs-devel@gnu.org; Wed, 11 May 2022 10:38:52 -0400 Original-Received: from filter006.mxroute.com ([140.82.40.27] 140.82.40.27.vultrusercontent.com) (Authenticated sender: mN4UYu2MZsgR) by mail-108-mta99.mxroute.com (ZoneMTA) with ESMTPSA id 180b38a39870000db4.001 for (version=TLSv1/SSLv3 cipher=ECDHE-RSA-AES128-GCM-SHA256); Wed, 11 May 2022 14:33:42 +0000 X-Zone-Loop: c053bf8cd28275cf38d3b5ce46d7f1208cf6454e5760 X-Originating-IP: [140.82.40.27] DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=neverwas.me ; s=x; h=Content-Type:MIME-Version:Message-ID:In-Reply-To:Date:References: Subject:Cc:To:From:Sender:Reply-To:Content-Transfer-Encoding:Content-ID: Content-Description:Resent-Date:Resent-From:Resent-Sender:Resent-To:Resent-Cc :Resent-Message-ID:List-Id:List-Help:List-Unsubscribe:List-Subscribe: List-Post:List-Owner:List-Archive; bh=85q20Fz8zlgqK9ppDE9NH6Jhu4Ag+DtCkYLCadroPsU=; b=bhG2yIvHU7nxiEIwUrDC1prHi+ 9NAfUjjBqJrDsjYU/IFe00jdQkSAkNKYW/CT9d05UQTZ8GSJ9S0ViRM2jDWXPfliAdWGS3AfJH4TX JdYlVF1VVWsDH8DIHDRwvKNK7epLq1HANkLKmf9cke+OC6XbiuY1r7YHNuRlGR4Byne0IVAkOrmtK cRee0CPGvDtjkhSLV1n0nTf4kLp7fYnUf2ZlzgCecz4OZukD9oIto1BfKMAr0772FRoz+0LDj4L3o a6XhxTO7wWju3my8DDhmtc7x1lQciYl0yoFqfnkSFI3FXPm/n4tIjRg+ilDIYtiX9wHVXMndHdoI5 cw+l5bxA==; In-Reply-To: (Ted Zlatanov's message of "Fri, 17 Sep 2021 09:24:30 +0000") X-AuthUser: masked@neverwas.me Received-SPF: pass client-ip=136.175.108.99; envelope-from=jp@neverwas.me; helo=mail-108-mta99.mxroute.com X-Spam_score_int: -16 X-Spam_score: -1.7 X-Spam_bar: - X-Spam_report: (-1.7 / 5.0 requ) BAYES_00=-1.9, DKIM_INVALID=0.1, DKIM_SIGNED=0.1, RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001, T_SCC_BODY_TEXT_LINE=-0.01 autolearn=no autolearn_force=no X-Spam_action: no action X-Mailman-Approved-At: Wed, 11 May 2022 11:52:58 -0400 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Original-Sender: "Emacs-devel" Xref: news.gmane.io gmane.emacs.devel:289641 Archived-At: --=-=-= Content-Type: text/plain Ted Zlatanov writes: > On Fri, 17 Sep 2021 08:40:06 +0000 Qiantan Hong 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")? --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-POC-Add-TLS-for-network-server-processes.patch >From 3d4850897109c96c07f26dcfe9001a0c6e4aa074 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" 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 "
%s\n\n%s\n
") + (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 --=-=-=--