master 9e24cde227a 1/2: Jsonrpc: add new jsonrpc-autoport-bootstrap helper

[João Távora]

branch: master
commit 9e24cde227a1bf2e1f0c005ca16b2a70e704ff5c
Author: João Távora <joaotavora@gmail.com>
Commit: João Távora <joaotavora@gmail.com>

    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.
---
 lisp/jsonrpc.el | 171 +++++++++++++++++++++++++++++++++++++++++++-------------
 1 file changed, 133 insertions(+), 38 deletions(-)

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 <joaotavora@gmail.com>
 ;; 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