jsonrpc-process-raw-connection.el

(require 'jsonrpc)

(defclass jsonrpc-process-raw-connection (jsonrpc-connection)
  ((-process
    :initarg :process :accessor jsonrpc--process
    :documentation "Process object wrapped by the this connection.")
   (-on-shutdown
    :accessor jsonrpc--on-shutdown
    :initform #'ignore
    :initarg :on-shutdown
    :documentation "Function run when the process dies."))
  :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.

:ON-SHUTDOWN (optional), a function of one argument, the
connection object, called when the process dies .")

(cl-defmethod initialize-instance ((conn jsonrpc-process-raw-connection) slots)
  (cl-call-next-method)
  (cl-destructuring-bind (&key ((:process proc)) name &allow-other-keys) slots
    ;; FIXME: notice the undocumented bad coupling in the stderr
    ;; buffer name, it must be named exactly like this we expect when
    ;; calling `make-process'.  If there were a `set-process-stderr'
    ;; like there is `set-process-buffer' we wouldn't need this and
    ;; 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))
          (read-only-mode t))))
    (setf (jsonrpc--process conn) proc)
    (set-process-buffer proc (get-buffer-create (format " *%s output*" name)))
    (set-process-filter proc #'jsonrpc--process-raw-filter)
    (set-process-sentinel proc #'jsonrpc--process-raw-sentinel)
    (with-current-buffer (process-buffer proc)
      (buffer-disable-undo)
      (set-marker (process-mark proc) (point-min))
      (let ((inhibit-read-only t)) (erase-buffer) (read-only-mode t)))
    (process-put proc 'jsonrpc-connection conn)))

(cl-defmethod jsonrpc-connection-send ((connection jsonrpc-process-raw-connection)
                                       &rest args
                                       &key
                                       _id
                                       method
                                       _params
                                       _result
                                       _error
                                       _partial)
  "Send MESSAGE, a JSON object, to CONNECTION."
  (when method
    (plist-put args :method
               (cond ((keywordp method) (substring (symbol-name method) 1))
                     ((and method (symbolp method)) (symbol-name method)))))
  (let* ( (message `(:jsonrpc "2.0" ,@args))
          (json (jsonrpc--json-encode message)))
    (process-send-string
     (jsonrpc--process connection)
     (format "%s" json))
    (jsonrpc--log-event connection message 'client)))

(cl-defmethod jsonrpc-running-p ((conn jsonrpc-process-raw-connection))
  "Return non-nil if JSONRPC connection CONN is running."
  (process-live-p (jsonrpc--process conn)))

(cl-defmethod jsonrpc-shutdown ((conn jsonrpc-process-raw-connection)
                                &optional cleanup)
  "Wait for JSONRPC connection CONN to shutdown.
With optional CLEANUP, kill any associated buffers."
  (unwind-protect
      (cl-loop
       with proc = (jsonrpc--process conn) for i from 0
       while (not (process-get proc 'jsonrpc-sentinel-cleanup-started))
       unless (zerop i) do
       (jsonrpc--warn "Sentinel for %s still hasn't run, deleting it!" proc)
       do
       (delete-process proc)
       (accept-process-output nil 0.1))
    (when cleanup
      (kill-buffer (process-buffer (jsonrpc--process conn)))
      (kill-buffer (jsonrpc-stderr-buffer conn)))))

(defun jsonrpc--process-raw-sentinel (proc change)
  "Called when PROC undergoes CHANGE."
  (let ((connection (process-get proc 'jsonrpc-connection)))
    (jsonrpc--debug connection `(:message "Connection state changed" :change ,change))
    (when (not (process-live-p proc))
      (with-current-buffer (jsonrpc-events-buffer connection)
        (let ((inhibit-read-only t))
          (insert "\n----------b---y---e---b---y---e----------\n")))
      ;; Cancel outstanding timers
      (maphash (lambda (_id triplet)
                 (pcase-let ((`(,_success ,_error ,timeout) triplet))
                   (when timeout (cancel-timer timeout))))
               (jsonrpc--request-continuations connection))
      (process-put proc 'jsonrpc-sentinel-cleanup-started t)
      (unwind-protect
          ;; Call all outstanding error handlers
          (maphash (lambda (_id triplet)
                     (pcase-let ((`(,_success ,error ,_timeout) triplet))
                       (funcall error '(:code -1 :message "Server died"))))
                   (jsonrpc--request-continuations connection))
        (jsonrpc--message "Server exited with status %s" (process-exit-status proc))
        (delete-process proc)
        (funcall (jsonrpc--on-shutdown connection) connection)))))

(defun jsonrpc--process-raw-filter (proc string)
  "Called when new data STRING has arrived for PROC."
  (when (buffer-live-p (process-buffer proc))
    (with-current-buffer (process-buffer proc)
      (let* ((inhibit-read-only t)
             (connection (process-get proc 'jsonrpc-connection)))
        ;; Insert the text, advancing the process marker.
        ;;
        (save-excursion
          (goto-char (process-mark proc))
          (insert string)
          (set-marker (process-mark proc) (point)))
        ;; Loop (more than one message might have arrived)
        ;;
        (let (done)
          (while (not done)
            ;; Attempt to complete a message
            ;;
            (let* ((start (point))
                   (json-message
                    (condition-case-unless-debug oops
                        (jsonrpc--json-read)
                      (json-end-of-file
                       nil)
                      (error
                       (jsonrpc--warn "Invalid JSON: %s %s"
                                      oops (buffer-substring start (point)))
                       (goto-char start)
                       nil))))
              (cond
               (json-message
                ;; Process content in another
                ;; buffer, shielding proc buffer from
                ;; tamper
                (delete-region start (point))
                (with-temp-buffer
                  (jsonrpc-connection-receive connection
                                              json-message)))
                (t
                 ;; Message is still incomplete
                 ;;
                 (setq done :waiting-for-more-bytes))))))))))