diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index e77da779cc5..ccff1381af2 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -2420,9 +2420,12 @@ has succeeded or failed. @item :tls-parameters When opening a TLS connection, this should be where the first element -is the TLS type, and the remaining elements should form a keyword list -acceptable for @code{gnutls-boot}. The TLS connection will then be -negotiated after completing the connection to the host. +is the TLS type (which should either be @code{gnutls-x509pki} or +@code{gnutls-anon}, and the remaining elements should form a keyword +list acceptable for @code{gnutls-boot}. (This keyword list can be +optained from the @code{gnutls-boot-parameters} function.) The TLS +connection will then be negotiated after completing the connection to +the host. @item :stop @var{stopped} If @var{stopped} is non-@code{nil}, start the network connection or diff --git a/doc/misc/emacs-gnutls.texi b/doc/misc/emacs-gnutls.texi index 75fd97c7c74..115727fb8ee 100644 --- a/doc/misc/emacs-gnutls.texi +++ b/doc/misc/emacs-gnutls.texi @@ -181,6 +181,10 @@ syntax are the same as those given to @code{open-network-stream} Manual}). The connection process is called @var{name} (made unique if necessary). This function returns the connection process. +The @var{nowait} parameter means that the scoket should be +asynchronous, and the connection process will be returned to the +caller before TLS negotiation has happened. + @lisp ;; open a HTTPS connection (open-gnutls-stream "tls" "tls-buffer" "yourserver.com" "https") diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index 8db665400eb..8db3450308d 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -110,7 +110,8 @@ Third arg is name of the host to connect to, or its IP address. Fourth arg SERVICE is name of the service desired, or an integer specifying a port number to connect to. Fifth arg NOWAIT (which is optional) means that the socket should -be opened asynchronously. +be opened asynchronously. The connection process will be +returned to the caller before TLS negotiation has happened. Usage example: @@ -129,12 +130,13 @@ trust and key files, and priority string." :nowait nowait :tls-parameters (and nowait - (gnutls-negotiate :type 'gnutls-x509pki - :return-keywords t - :hostname host))))) + (cons 'gnutls-x509pki + (gnutls-boot-parameters + :type 'gnutls-x509pki + :hostname host)))))) (if nowait process - (gnutls-negotiate :process (open-network-stream name buffer host service) + (gnutls-negotiate :process process :type 'gnutls-x509pki :hostname host)))) @@ -149,14 +151,48 @@ trust and key files, and priority string." &key process type hostname priority-string trustfiles crlfiles keylist min-prime-bits verify-flags verify-error verify-hostname-error - return-keywords &allow-other-keys) "Negotiate a SSL/TLS connection. Returns proc. Signals gnutls-error. -Note arguments are passed CL style, :type TYPE instead of just TYPE. +Note that arguments are passed CL style, :type TYPE instead of just TYPE. + +PROCESS is a process returned by `open-network-stream'. +For the meaning of the rest of the parameters, see `gnutls-boot-parameters'." + (let* ((type (or type 'gnutls-x509pki)) + ;; The gnutls library doesn't understand files delivered via + ;; the special handlers, so ignore all files found via those. + (file-name-handler-alist nil) + (params (gnutls-boot-parameters + :type type + :hostname hostname + :priority-string priority-string + :trustfiles trustfiles + :crlfiles crlfiles + :keylist keylist + :min-prime-bits min-prime-bits + :verify-flags verify-flags + :verify-error verify-error + :verify-hostname-error verify-hostname-error)) + ret) + (gnutls-message-maybe + (setq ret (gnutls-boot process type params)) + "boot: %s" params) + + (when (gnutls-errorp ret) + ;; This is a error from the underlying C code. + (signal 'gnutls-error (list process ret))) + + process)) + +(cl-defun gnutls-boot-parameters + (&rest spec + &key type hostname priority-string + trustfiles crlfiles keylist min-prime-bits + verify-flags verify-error verify-hostname-error + &allow-other-keys) + "Return a keyword list of parameters suitable for passing to `gnutls-boot'. TYPE is `gnutls-x509pki' (default) or `gnutls-anon'. Use nil for the default. -PROCESS is a process returned by `open-network-stream'. HOSTNAME is the remote hostname. It must be a valid string. PRIORITY-STRING is as per the GnuTLS docs, default is \"NORMAL\". TRUSTFILES is a list of CA bundles. It defaults to `gnutls-trustfiles'. @@ -201,71 +237,48 @@ here's a recent version of the list. GNUTLS_VERIFY_DO_NOT_ALLOW_X509_V1_CA_CRT = 256 It must be omitted, a number, or nil; if omitted or nil it -defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT. - -If RETURN-KEYWORDS, don't connect to anything, but just return -the computed parameters that we otherwise would be calling -gnutls-boot with. The return value will be a list where the -first element is the TLS type, and the rest of the list consists -of the keywords." - (let* ((type (or type 'gnutls-x509pki)) - ;; The gnutls library doesn't understand files delivered via - ;; the special handlers, so ignore all files found via those. - (file-name-handler-alist nil) - (trustfiles (or trustfiles (gnutls-trustfiles))) - (priority-string (or priority-string - (cond - ((eq type 'gnutls-anon) - "NORMAL:+ANON-DH:!ARCFOUR-128") - ((eq type 'gnutls-x509pki) - (if gnutls-algorithm-priority - (upcase gnutls-algorithm-priority) - "NORMAL"))))) - (verify-error (or verify-error - ;; this uses the value of `gnutls-verify-error' - (cond - ;; if t, pass it on - ((eq gnutls-verify-error t) - t) - ;; if a list, look for hostname matches - ((listp gnutls-verify-error) - (apply 'append - (mapcar - (lambda (check) - (when (string-match (nth 0 check) - hostname) - (nth 1 check))) - gnutls-verify-error))) - ;; else it's nil - (t nil)))) - (min-prime-bits (or min-prime-bits gnutls-min-prime-bits)) - params ret) +defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT." + (let ((trustfiles (or trustfiles (gnutls-trustfiles))) + (priority-string (or priority-string + (cond + ((eq type 'gnutls-anon) + "NORMAL:+ANON-DH:!ARCFOUR-128") + ((eq type 'gnutls-x509pki) + (if gnutls-algorithm-priority + (upcase gnutls-algorithm-priority) + "NORMAL"))))) + (verify-error (or verify-error + ;; this uses the value of `gnutls-verify-error' + (cond + ;; if t, pass it on + ((eq gnutls-verify-error t) + t) + ;; if a list, look for hostname matches + ((listp gnutls-verify-error) + (apply 'append + (mapcar + (lambda (check) + (when (string-match (nth 0 check) + hostname) + (nth 1 check))) + gnutls-verify-error))) + ;; else it's nil + (t nil)))) + (min-prime-bits (or min-prime-bits gnutls-min-prime-bits))) (when verify-hostname-error (push :hostname verify-error)) - (setq params `(:priority ,priority-string - :hostname ,hostname - :loglevel ,gnutls-log-level - :min-prime-bits ,min-prime-bits - :trustfiles ,trustfiles - :crlfiles ,crlfiles - :keylist ,keylist - :verify-flags ,verify-flags - :verify-error ,verify-error - :callbacks nil)) - - (if return-keywords - (cons type params) - (gnutls-message-maybe - (setq ret (gnutls-boot process type params)) - "boot: %s" params) - - (when (gnutls-errorp ret) - ;; This is a error from the underlying C code. - (signal 'gnutls-error (list process ret))) - - process))) + `(:priority ,priority-string + :hostname ,hostname + :loglevel ,gnutls-log-level + :min-prime-bits ,min-prime-bits + :trustfiles ,trustfiles + :crlfiles ,crlfiles + :keylist ,keylist + :verify-flags ,verify-flags + :verify-error ,verify-error + :callbacks nil))) (defun gnutls-trustfiles () "Return a list of usable trustfiles." diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index acbdb7a71b2..4925805a32e 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -140,9 +140,10 @@ a greeting from the server. asynchronously, if possible. :tls-parameters is a list that should be supplied if you're -opening a TLS connection. The first element is the TLS type, and -the remaining elements should be a keyword list accepted by -gnutls-boot." +opening a TLS connection. The first element is the TLS +type (either `gnutls-x509pki' or `gnutls-anon'), and the +remaining elements should be a keyword list accepted by +gnutls-boot (as returned by `gnutls-boot-parameters')." (unless (featurep 'make-network-process) (error "Emacs was compiled without networking support")) (let ((type (plist-get parameters :type)) diff --git a/src/eval.c b/src/eval.c index 6c912bc4762..c01dd09199f 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1751,9 +1751,9 @@ find_handler_clause (Lisp_Object handlers, Lisp_Object conditions) } -/* Dump an error message; called like vprintf. */ -void -verror (const char *m, va_list ap) +/* Format and return a string; called like vprintf. */ +Lisp_Object +vformat_string (const char *m, va_list ap) { char buf[4000]; ptrdiff_t size = sizeof buf; @@ -1767,7 +1767,14 @@ verror (const char *m, va_list ap) if (buffer != buf) xfree (buffer); - xsignal1 (Qerror, string); + return string; +} + +/* Dump an error message; called like vprintf. */ +void +verror (const char *m, va_list ap) +{ + xsignal1 (Qerror, vformat_string (m, ap)); } diff --git a/src/gnutls.c b/src/gnutls.c index fb3c3c22777..948a0c56f14 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -1174,7 +1174,7 @@ boot_error (struct Lisp_Process *p, const char *m, ...) va_list ap; va_start (ap, m); if (p->is_non_blocking_client) - pset_status (p, Qfailed); + pset_status (p, list2 (Qfailed, vformat_string (m, ap))); else verror (m, ap); } diff --git a/src/lisp.h b/src/lisp.h index 02b8078a9fd..e87f47510f8 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3908,6 +3908,8 @@ extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object); extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2); extern _Noreturn void verror (const char *, va_list) ATTRIBUTE_FORMAT_PRINTF (1, 0); +extern Lisp_Object vformat_string (const char *, va_list) + ATTRIBUTE_FORMAT_PRINTF (1, 0); extern void un_autoload (Lisp_Object); extern Lisp_Object call_debugger (Lisp_Object arg); extern void *near_C_stack_top (void); diff --git a/src/process.c b/src/process.c index e4dd123574e..0c8fc43dd12 100644 --- a/src/process.c +++ b/src/process.c @@ -3454,8 +3454,10 @@ and MESSAGE is a string. :plist PLIST -- Install PLIST as the new process's initial plist. :tls-parameters LIST -- is a list that should be supplied if you're -opening a TLS connection. The first element is the TLS type, and the -remaining elements should be a keyword list accepted by gnutls-boot. +opening a TLS connection. The first element is the TLS type (either +`gnutls-x509pki' or `gnutls-anon'), and the remaining elements should +be a keyword list accepted by gnutls-boot (as returned by +`gnutls-boot-parameters'). :server QLEN -- if QLEN is non-nil, create a server process for the specified FAMILY, SERVICE, and connection type (stream or datagram).