From: João Távora Date: Thu, 14 Dec 2023 22:56:33 +0000 (+0000) Subject: Jsonrpc: add new jsonrpc-autoport-bootstrap helper X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=9e24cde227a1bf2e1f0c005ca16b2a70e704ff5c;p=emacs.git Jsonrpc: add new jsonrpc-autoport-bootstrap helper This will help Eglot and some other extensions connect to network servers that are started with a call to a local program. * lisp/jsonrpc.el (jsonrpc--process-sentinel): Also delete inferior. (jsonrpc-process-connection): Add -autoport-inferior slot. (initialize-instance jsonrpc-process-connection): Check process-creating function arity. Use jsonrpc-forwarding-buffer (jsonrpc-autoport-bootstrap): New helper. (Version): Bump to 1.0.20. --- diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index dde1c880912..f5db3674366 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -4,7 +4,7 @@ ;; Author: João Távora ;; Keywords: processes, languages, extensions -;; Version: 1.0.19 +;; Version: 1.0.20 ;; Package-Requires: ((emacs "25.2")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -400,16 +400,20 @@ ignored." :accessor jsonrpc--on-shutdown :initform #'ignore :initarg :on-shutdown - :documentation "Function run when the process dies.")) + :documentation "Function run when the process dies.") + (-autoport-inferior + :initform nil + :documentation "Used by `jsonrpc-autoport-bootstrap'.")) :documentation "A JSONRPC connection over an Emacs process. The following initargs are accepted: :PROCESS (mandatory), a live running Emacs process object or a -function of no arguments producing one such object. The process -represents either a pipe connection to locally running process or -a stream connection to a network host. The remote endpoint is -expected to understand JSONRPC messages with basic HTTP-style -enveloping headers such as \"Content-Length:\". +function producing one such object. If a function, it is passed +the `jsonrpc-process-connection' object. The process represents +either a pipe connection to locally running process or a stream +connection to a network host. The remote endpoint is expected to +understand JSONRPC messages with basic HTTP-style enveloping +headers such as \"Content-Length:\". :ON-SHUTDOWN (optional), a function of one argument, the connection object, called when the process dies.") @@ -424,37 +428,22 @@ connection object, called when the process dies.") ;; could use a pipe with a process filter instead of ;; `after-change-functions'. Alternatively, we need a new initarg ;; (but maybe not a slot). - (let ((calling-buffer (current-buffer))) - (with-current-buffer (get-buffer-create (format "*%s stderr*" name)) - (let ((inhibit-read-only t) - (hidden-name (concat " " (buffer-name)))) - (erase-buffer) - (buffer-disable-undo) - (add-hook - 'after-change-functions - (lambda (beg _end _pre-change-len) - (cl-loop initially (goto-char beg) - do (forward-line) - when (bolp) - for line = (buffer-substring - (line-beginning-position 0) - (line-end-position 0)) - do (with-current-buffer (jsonrpc-events-buffer conn) - (goto-char (point-max)) - (let ((inhibit-read-only t)) - (insert (format "[stderr] %s\n" line)))) - until (eobp))) - nil t) - ;; If we are correctly coupled to the client, the process - ;; now created should pick up the current stderr buffer, - ;; which we immediately rename - (setq proc (if (functionp proc) - (with-current-buffer calling-buffer (funcall proc)) - proc)) - (ignore-errors (kill-buffer hidden-name)) - (rename-buffer hidden-name) - (process-put proc 'jsonrpc-stderr (current-buffer)) - (setq buffer-read-only t)))) + (let* ((stderr-buffer-name (format "*%s stderr*" name)) + (stderr-buffer (jsonrpc--forwarding-buffer stderr-buffer-name "[stderr]" conn)) + (hidden-name (concat " " stderr-buffer-name))) + ;; If we are correctly coupled to the client, the process now + ;; created should pick up the `stderr-buffer' just created, which + ;; we immediately rename + (setq proc (if (functionp proc) + (if (zerop (cdr (func-arity proc))) + (funcall proc) + (funcall proc conn)) + proc)) + (with-current-buffer stderr-buffer + (ignore-errors (kill-buffer hidden-name)) + (rename-buffer hidden-name) + (setq buffer-read-only t)) + (process-put proc 'jsonrpc-stderr stderr-buffer)) (setf (jsonrpc--process conn) proc) (set-process-buffer proc (get-buffer-create (format " *%s output*" name))) (set-process-filter proc #'jsonrpc--process-filter) @@ -601,6 +590,7 @@ With optional CLEANUP, kill any associated buffers." (jsonrpc--request-continuations connection)) (jsonrpc--message "Server exited with status %s" (process-exit-status proc)) (delete-process proc) + (when-let (p (slot-value connection '-autoport-inferior)) (delete-process p)) (funcall (jsonrpc--on-shutdown connection) connection))))) (cl-defun jsonrpc--process-filter (proc string) @@ -811,5 +801,110 @@ SUBTYPE tells more about the event." (forward-line 2) (point))))))))))))) +(defun jsonrpc--forwarding-buffer (name prefix conn) + "Helper for `jsonrpc-process-connection' helpers. +Make a stderr buffer named NAME, forwarding lines prefixed by +PREFIX to CONN's events buffer." + (with-current-buffer (get-buffer-create name) + (let ((inhibit-read-only t)) + (fundamental-mode) + (erase-buffer) + (buffer-disable-undo) + (add-hook + 'after-change-functions + (lambda (beg _end _pre-change-len) + (cl-loop initially (goto-char beg) + do (forward-line) + when (bolp) + for line = (buffer-substring + (line-beginning-position 0) + (line-end-position 0)) + do (with-current-buffer (jsonrpc-events-buffer conn) + (goto-char (point-max)) + (let ((inhibit-read-only t)) + (insert (format "%s %s\n" prefix line)))) + until (eobp))) + nil t)) + (current-buffer))) + + +;;;; More convenience utils +(cl-defun jsonrpc-autoport-bootstrap (name contact + &key connect-args) + "Use CONTACT to start network server, then connect to it. + +Return function suitable for the :PROCESS initarg of +`jsonrpc-process-connection' (which see). + +CONTACT is a list where all the elements are strings except for +one, which is usuallky the keyword `:autoport'. + +When the returned function is called it will start a program +using a command based on CONTACT, where `:autoport' is +substituted by a locally free network port. Thereafter, a +network is made to this port. + +Instead of the keyword `:autoport', a cons cell (:autoport +FORMAT-FN) is also accepted. In that case FORMAT-FN is passed +the port number and should return a string used for the +substitution. + +The internal processes and control buffers are named after NAME. + +CONNECT-ARGS are passed as additional arguments to +`open-network-stream'." + (lambda (conn) + (let* ((port-probe (make-network-process :name "jsonrpc-port-probe-dummy" + :server t + :host "localhost" + :service 0)) + (port-number (unwind-protect + (process-contact port-probe :service) + (delete-process port-probe))) + (inferior-buffer (jsonrpc--forwarding-buffer + (format " *%s inferior output*" name) + "[inferior]" + conn)) + (cmd (cl-loop for e in contact + if (eq e :autoport) collect (format "%s" port-number) + else if (eq (car-safe e) :autoport) + collect (funcall (cdr e) port-number) + else collect e)) + inferior np) + (unwind-protect + (progn + (message "[jsonrpc] Attempting to start `%s'" + (string-join cmd " ")) + (setq inferior + (make-process + :name (format "inferior (%s)" name) + :buffer inferior-buffer + :noquery t + :command cmd)) + (setq np + (cl-loop + repeat 10 for i from 0 + do (accept-process-output nil 0.5) + while (process-live-p inferior) + do (message + "[jsonrpc] %sTrying to connect to localhost:%s (attempt %s)" + (if (zerop i) "Started. " "") + port-number (1+ i)) + thereis (ignore-errors + (apply #'open-network-stream + (format "autostart (%s)" name) + nil + "localhost" port-number connect-args)))) + (setf (slot-value conn '-autoport-inferior) inferior) + np) + (cond ((and (process-live-p np) + (process-live-p inferior)) + (message "[jsonrpc] Done, connected to %s!" port-number)) + (t + (when inferior (delete-process inferior)) + (when np (delete-process np)) + (error "[jsonrpc] Could not start and/or connect"))))))) + + (provide 'jsonrpc) ;;; jsonrpc.el ends here