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