nrepl-client.el (64785B)
1 ;;; nrepl-client.el --- Client for Clojure nREPL -*- lexical-binding: t -*- 2 3 ;; Copyright © 2012-2013 Tim King, Phil Hagelberg, Bozhidar Batsov 4 ;; Copyright © 2013-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors 5 ;; 6 ;; Author: Tim King <kingtim@gmail.com> 7 ;; Phil Hagelberg <technomancy@gmail.com> 8 ;; Bozhidar Batsov <bozhidar@batsov.dev> 9 ;; Artur Malabarba <bruce.connor.am@gmail.com> 10 ;; Hugo Duncan <hugo@hugoduncan.org> 11 ;; Steve Purcell <steve@sanityinc.com> 12 ;; Reid McKenzie <me@arrdem.com> 13 ;; 14 ;; This program is free software: you can redistribute it and/or modify 15 ;; it under the terms of the GNU General Public License as published by 16 ;; the Free Software Foundation, either version 3 of the License, or 17 ;; (at your option) any later version. 18 ;; 19 ;; This program is distributed in the hope that it will be useful, 20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 22 ;; GNU General Public License for more details. 23 ;; 24 ;; You should have received a copy of the GNU General Public License 25 ;; along with this program. If not, see <http://www.gnu.org/licenses/>. 26 ;; 27 ;; This file is not part of GNU Emacs. 28 ;; 29 ;;; Commentary: 30 ;; 31 ;; Provides an Emacs Lisp client to connect to Clojure nREPL servers. 32 ;; 33 ;; A connection is an abstract idea of the communication between Emacs (client) 34 ;; and nREPL server. On the Emacs side connections are represented by two 35 ;; running processes. The two processes are the server process and client 36 ;; process (the connection to the server). Each of these is represented by its 37 ;; own process buffer, filter and sentinel. 38 ;; 39 ;; The nREPL communication process can be broadly represented as follows: 40 ;; 41 ;; 1) The server process is started as an Emacs subprocess (usually by 42 ;; `cider-jack-in', which in turn fires up an nREPL server). Note that 43 ;; if a connection was established using `cider-connect' there won't be 44 ;; a server process. 45 ;; 46 ;; 2) The server's process filter (`nrepl-server-filter') detects the 47 ;; connection port from the first plain text response from the server and 48 ;; starts a communication process (socket connection) as another Emacs 49 ;; subprocess. This is the nREPL client process (`nrepl-client-filter'). 50 ;; All requests and responses handling happens through this client 51 ;; connection. 52 ;; 53 ;; 3) Requests are sent by `nrepl-send-request' and 54 ;; `nrepl-send-sync-request'. A request is simply a list containing a 55 ;; requested operation name and the parameters required by the 56 ;; operation. Each request has an associated callback that is called once 57 ;; the response for the request has arrived. Besides the above functions 58 ;; there are specialized request senders for each type of common 59 ;; operations. Examples are `nrepl-request:eval', `nrepl-request:clone', 60 ;; `nrepl-sync-request:describe'. 61 ;; 62 ;; 4) Responses from the server are decoded in `nrepl-client-filter' and are 63 ;; physically represented by alists whose structure depends on the type of 64 ;; the response. After having been decoded, the data from the response is 65 ;; passed over to the callback that was registered by the original 66 ;; request. 67 ;; 68 ;; Please see the comments in dedicated sections of this file for more detailed 69 ;; description. 70 71 ;;; Code: 72 (require 'seq) 73 (require 'subr-x) 74 (require 'cl-lib) 75 (require 'nrepl-dict) 76 (require 'queue) 77 (require 'sesman) 78 (require 'tramp) 79 80 81 ;;; Custom 82 83 (defgroup nrepl nil 84 "Interaction with the Clojure nREPL Server." 85 :prefix "nrepl-" 86 :group 'applications) 87 88 ;; (defcustom nrepl-buffer-name-separator " " 89 ;; "Used in constructing the REPL buffer name. 90 ;; The `nrepl-buffer-name-separator' separates cider-repl from the project name." 91 ;; :type '(string) 92 ;; :group 'nrepl) 93 (make-obsolete-variable 'nrepl-buffer-name-separator 'cider-session-name-template "0.18") 94 95 ;; (defcustom nrepl-buffer-name-show-port nil 96 ;; "Show the connection port in the nrepl REPL buffer name, if set to t." 97 ;; :type 'boolean 98 ;; :group 'nrepl) 99 (make-obsolete-variable 'nrepl-buffer-name-show-port 'cider-session-name-template "0.18") 100 101 (defcustom nrepl-connected-hook nil 102 "List of functions to call when connecting to the nREPL server." 103 :type 'hook) 104 105 (defcustom nrepl-disconnected-hook nil 106 "List of functions to call when disconnected from the nREPL server." 107 :type 'hook) 108 109 (defcustom nrepl-force-ssh-for-remote-hosts nil 110 "If non-nil, do not attempt a direct connection for remote hosts." 111 :type 'boolean) 112 113 (defcustom nrepl-use-ssh-fallback-for-remote-hosts nil 114 "If non-nil, Use ssh as a fallback to connect to remote hosts. 115 It will attempt to connect via ssh to remote hosts when unable to connect 116 directly." 117 :type 'boolean) 118 119 (defcustom nrepl-sync-request-timeout 10 120 "The number of seconds to wait for a sync response. 121 Setting this to nil disables the timeout functionality." 122 :type 'integer) 123 124 (defcustom nrepl-hide-special-buffers nil 125 "Control the display of some special buffers in buffer switching commands. 126 When true some special buffers like the server buffer will be hidden." 127 :type 'boolean) 128 129 130 ;;; Buffer Local Declarations 131 132 ;; These variables are used to track the state of nREPL connections 133 (defvar-local nrepl-connection-buffer nil) 134 (defvar-local nrepl-server-buffer nil) 135 (defvar-local nrepl-messages-buffer nil) 136 (defvar-local nrepl-endpoint nil) 137 (defvar-local nrepl-project-dir nil) 138 (defvar-local nrepl-is-server nil) 139 (defvar-local nrepl-server-command nil) 140 (defvar-local nrepl-tunnel-buffer nil) 141 142 (defvar-local nrepl-session nil 143 "Current nREPL session id.") 144 145 (defvar-local nrepl-tooling-session nil 146 "Current nREPL tooling session id. 147 To be used for tooling calls (i.e. completion, eldoc, etc)") 148 149 (defvar-local nrepl-request-counter 0 150 "Continuation serial number counter.") 151 152 (defvar-local nrepl-pending-requests nil) 153 154 (defvar-local nrepl-completed-requests nil) 155 156 (defvar-local nrepl-last-sync-response nil 157 "Result of the last sync request.") 158 159 (defvar-local nrepl-last-sync-request-timestamp nil 160 "The time when the last sync request was initiated.") 161 162 (defvar-local nrepl-ops nil 163 "Available nREPL server ops (from describe).") 164 165 (defvar-local nrepl-versions nil 166 "Version information received from the describe op.") 167 168 (defvar-local nrepl-aux nil 169 "Auxiliary information received from the describe op.") 170 171 172 ;;; nREPL Buffer Names 173 174 (defconst nrepl-message-buffer-name-template "*nrepl-messages %s(%r:%S)*") 175 (defconst nrepl-error-buffer-name "*nrepl-error*") 176 (defconst nrepl-repl-buffer-name-template "*cider-repl %s(%r:%S)*") 177 (defconst nrepl-server-buffer-name-template "*nrepl-server %s*") 178 (defconst nrepl-tunnel-buffer-name-template "*nrepl-tunnel %s*") 179 180 (declare-function cider-format-connection-params "cider-connection") 181 (defun nrepl-make-buffer-name (template params &optional dup-ok) 182 "Generate a buffer name using TEMPLATE and PARAMS. 183 TEMPLATE and PARAMS are as in `cider-format-connection-params'. If 184 optional DUP-OK is non-nil, the returned buffer is not \"uniquified\" by a 185 call to `generate-new-buffer-name'." 186 (let ((name (cider-format-connection-params template params))) 187 (if dup-ok 188 name 189 (generate-new-buffer-name name)))) 190 191 (defun nrepl--make-hidden-name (buffer-name) 192 "Apply a prefix to BUFFER-NAME that will hide the buffer." 193 (concat (if nrepl-hide-special-buffers " " "") buffer-name)) 194 195 (defun nrepl-repl-buffer-name (params &optional dup-ok) 196 "Return the name of the repl buffer. 197 PARAMS and DUP-OK are as in `nrepl-make-buffer-name'." 198 (nrepl-make-buffer-name nrepl-repl-buffer-name-template params dup-ok)) 199 200 (defun nrepl-server-buffer-name (params) 201 "Return the name of the server buffer. 202 PARAMS is as in `nrepl-make-buffer-name'." 203 (nrepl-make-buffer-name (nrepl--make-hidden-name nrepl-server-buffer-name-template) 204 params)) 205 206 (defun nrepl-tunnel-buffer-name (params) 207 "Return the name of the tunnel buffer. 208 PARAMS is as in `nrepl-make-buffer-name'." 209 (nrepl-make-buffer-name (nrepl--make-hidden-name nrepl-tunnel-buffer-name-template) 210 params)) 211 212 (defun nrepl-messages-buffer-name (params) 213 "Return the name for the message buffer given connection PARAMS." 214 (nrepl-make-buffer-name nrepl-message-buffer-name-template params)) 215 216 217 ;;; Utilities 218 (defun nrepl-op-supported-p (op connection) 219 "Return t iff the given operation OP is supported by the nREPL CONNECTION." 220 (when (buffer-live-p connection) 221 (with-current-buffer connection 222 (and nrepl-ops (nrepl-dict-get nrepl-ops op))))) 223 224 (defun nrepl-aux-info (key connection) 225 "Return KEY's aux info, as returned via the :describe op for CONNECTION." 226 (with-current-buffer connection 227 (and nrepl-aux (nrepl-dict-get nrepl-aux key)))) 228 229 (defun nrepl-local-host-p (host) 230 "Return t if HOST is local." 231 (string-match-p tramp-local-host-regexp host)) 232 233 (defun nrepl-extract-port (dir) 234 "Read port from applicable repl-port file in directory DIR." 235 (or (nrepl--port-from-file (expand-file-name "repl-port" dir)) 236 (nrepl--port-from-file (expand-file-name ".nrepl-port" dir)) 237 (nrepl--port-from-file (expand-file-name "target/repl-port" dir)) 238 (nrepl--port-from-file (expand-file-name ".shadow-cljs/nrepl.port" dir)))) 239 240 (defun nrepl-extract-ports (dir) 241 "Read ports from applicable repl-port files in directory DIR." 242 (delq nil 243 (list (nrepl--port-from-file (expand-file-name "repl-port" dir)) 244 (nrepl--port-from-file (expand-file-name ".nrepl-port" dir)) 245 (nrepl--port-from-file (expand-file-name "target/repl-port" dir)) 246 (nrepl--port-from-file (expand-file-name ".shadow-cljs/nrepl.port" dir))))) 247 248 (make-obsolete 'nrepl-extract-port 'nrepl-extract-ports "1.5.0") 249 250 (defun nrepl--port-from-file (file) 251 "Attempts to read port from a file named by FILE." 252 (when (file-exists-p file) 253 (with-temp-buffer 254 (insert-file-contents file) 255 (buffer-string)))) 256 257 258 ;;; Bencode 259 260 (cl-defstruct (nrepl-response-queue 261 (:include queue) 262 (:constructor nil) 263 (:constructor nrepl-response-queue (&optional stub))) 264 stub) 265 266 (put 'nrepl-response-queue 'function-documentation 267 "Create queue object used by nREPL to store decoded server responses. 268 The STUB slot stores a stack of nested, incompletely parsed objects.") 269 270 (defun nrepl--bdecode-list (&optional stack) 271 "Decode a bencode list or dict starting at point. 272 STACK is as in `nrepl--bdecode-1'." 273 ;; skip leading l or d 274 (forward-char 1) 275 (let* ((istack (nrepl--bdecode-1 stack)) 276 (pos0 (point)) 277 (info (car istack))) 278 (while (null info) 279 (setq istack (nrepl--bdecode-1 (cdr istack)) 280 pos0 (point) 281 info (car istack))) 282 (cond ((eq info :e) 283 (cons nil (cdr istack))) 284 ((eq info :stub) 285 (goto-char pos0) 286 istack) 287 (t istack)))) 288 289 (defun nrepl--bdecode-1 (&optional stack) 290 "Decode one elementary bencode object starting at point. 291 Bencoded object is either list, dict, integer or string. See 292 http://en.wikipedia.org/wiki/Bencode#Encoding_algorithm for the encoding 293 rules. 294 295 STACK is a list of so far decoded components of the current message. Car 296 of STACK is the innermost incompletely decoded object. The algorithm pops 297 this list when inner object was completely decoded or grows it by one when 298 new list or dict was encountered. 299 300 The returned value is of the form (INFO . STACK) where INFO is 301 :stub, nil, :end or :eob and STACK is either an incomplete parsing state as 302 above (INFO is :stub, nil or :eob) or a list of one component representing 303 the completely decoded message (INFO is :end). INFO is nil when an 304 elementary non-root object was successfully decoded. INFO is :end when this 305 object is a root list or dict." 306 (cond 307 ;; list 308 ((eq (char-after) ?l) 309 (nrepl--bdecode-list (cons () stack))) 310 ;; dict 311 ((eq (char-after) ?d) 312 (nrepl--bdecode-list (cons '(dict) stack))) 313 ;; end of a list or a dict 314 ((eq (char-after) ?e) 315 (forward-char 1) 316 (cons (if (cdr stack) :e :end) 317 (nrepl--push (nrepl--nreverse (car stack)) 318 (cdr stack)))) 319 ;; string 320 ((looking-at "\\([0-9]+\\):") 321 (let ((pos0 (point)) 322 (beg (goto-char (match-end 0))) 323 (end (byte-to-position (+ (position-bytes (point)) 324 (string-to-number (match-string 1)))))) 325 (if (null end) 326 (progn (goto-char pos0) 327 (cons :stub stack)) 328 (goto-char end) 329 ;; normalise any platform-specific newlines 330 (let* ((original (buffer-substring-no-properties beg end)) 331 (result (replace-regexp-in-string "\r\n\\|\n\r\\|\r" "\n" original))) 332 (cons nil (nrepl--push result stack)))))) 333 ;; integer 334 ((looking-at "i\\(-?[0-9]+\\)e") 335 (goto-char (match-end 0)) 336 (cons nil (nrepl--push (string-to-number (match-string 1)) 337 stack))) 338 ;; should happen in tests only as eobp is checked in nrepl-bdecode. 339 ((eobp) 340 (cons :eob stack)) 341 ;; truncation in the middle of an integer or in 123: string prefix 342 ((looking-at-p "[0-9i]") 343 (cons :stub stack)) 344 ;; else, throw a quiet error 345 (t 346 (message "Invalid bencode message detected. See the %s buffer for details." 347 nrepl-error-buffer-name) 348 (nrepl-log-error 349 (format "Decoder error at position %d (`%s'):" 350 (point) (buffer-substring (point) (min (+ (point) 10) (point-max))))) 351 (nrepl-log-error (buffer-string)) 352 (ding) 353 ;; Ensure loop break and clean queues' states in nrepl-bdecode: 354 (goto-char (point-max)) 355 (cons :end nil)))) 356 357 (defun nrepl--bdecode-message (&optional stack) 358 "Decode one full message starting at point. 359 STACK is as in `nrepl--bdecode-1'. Return a cons (INFO . STACK)." 360 (let* ((istack (nrepl--bdecode-1 stack)) 361 (info (car istack)) 362 (stack (cdr istack))) 363 (while (or (null info) 364 (eq info :e)) 365 (setq istack (nrepl--bdecode-1 stack) 366 info (car istack) 367 stack (cdr istack))) 368 istack)) 369 370 (defun nrepl--ensure-fundamental-mode () 371 "Enable `fundamental-mode' if it is not enabled already." 372 (when (not (eq 'fundamental-mode major-mode)) 373 (fundamental-mode))) 374 375 (defun nrepl-bdecode (string-q &optional response-q) 376 "Decode STRING-Q and place the results into RESPONSE-Q. 377 STRING-Q is either a queue of strings or a string. RESPONSE-Q is a queue of 378 server requests (nREPL dicts). STRING-Q and RESPONSE-Q are modified by side 379 effects. 380 381 Return a cons (STRING-Q . RESPONSE-Q) where STRING-Q is the original queue 382 containing the remainder of the input strings which could not be 383 decoded. RESPONSE-Q is the original queue with successfully decoded messages 384 enqueued and with slot STUB containing a nested stack of an incompletely 385 decoded message or nil if the strings were completely decoded." 386 (with-current-buffer (get-buffer-create " *nrepl-decoding*") 387 ;; Don't needlessly call `fundamental-mode', to prevent needlessly firing 388 ;; hooks. This fixes an issue with evil-mode where the cursor loses its 389 ;; correct color. 390 (nrepl--ensure-fundamental-mode) 391 (erase-buffer) 392 (if (queue-p string-q) 393 (while (queue-head string-q) 394 (insert (queue-dequeue string-q))) 395 (insert string-q) 396 (setq string-q (queue-create))) 397 (goto-char 1) 398 (unless response-q 399 (setq response-q (nrepl-response-queue))) 400 (let ((istack (nrepl--bdecode-message 401 (nrepl-response-queue-stub response-q)))) 402 (while (and (eq (car istack) :end) 403 (not (eobp))) 404 (queue-enqueue response-q (cadr istack)) 405 (setq istack (nrepl--bdecode-message))) 406 (unless (eobp) 407 (queue-enqueue string-q (buffer-substring (point) (point-max)))) 408 (if (not (eq (car istack) :end)) 409 (setf (nrepl-response-queue-stub response-q) (cdr istack)) 410 (queue-enqueue response-q (cadr istack)) 411 (setf (nrepl-response-queue-stub response-q) nil)) 412 (erase-buffer) 413 (cons string-q response-q)))) 414 415 (defun nrepl-bencode (object) 416 "Encode OBJECT with bencode. 417 Integers, lists and nrepl-dicts are treated according to bencode 418 specification. Everything else is encoded as string." 419 (cond 420 ((integerp object) (format "i%de" object)) 421 ((nrepl-dict-p object) (format "d%se" (mapconcat #'nrepl-bencode (cdr object) ""))) 422 ((listp object) (format "l%se" (mapconcat #'nrepl-bencode object ""))) 423 (t (format "%s:%s" (string-bytes object) object)))) 424 425 426 ;;; Client: Process Filter 427 428 (defvar nrepl-response-handler-functions nil 429 "List of functions to call on each nREPL message. 430 Each of these functions should be a function with one argument, which will 431 be called by `nrepl-client-filter' on every response received. The current 432 buffer will be connection (REPL) buffer of the process. These functions 433 should take a single argument, a dict representing the message. See 434 `nrepl--dispatch-response' for an example. 435 436 These functions are called before the message's own callbacks, so that they 437 can affect the behavior of the callbacks. Errors signaled by these 438 functions are demoted to messages, so that they don't prevent the 439 callbacks from running.") 440 441 (defun nrepl-client-filter (proc string) 442 "Decode message(s) from PROC contained in STRING and dispatch them." 443 (let ((string-q (process-get proc :string-q))) 444 (queue-enqueue string-q string) 445 ;; Start decoding only if the last letter is 'e' 446 (when (eq ?e (aref string (1- (length string)))) 447 (let ((response-q (process-get proc :response-q))) 448 (nrepl-bdecode string-q response-q) 449 (while (queue-head response-q) 450 (with-current-buffer (process-buffer proc) 451 (let ((response (queue-dequeue response-q))) 452 (with-demoted-errors "Error in one of the `nrepl-response-handler-functions': %s" 453 (run-hook-with-args 'nrepl-response-handler-functions response)) 454 (nrepl--dispatch-response response)))))))) 455 456 (defun nrepl--dispatch-response (response) 457 "Dispatch the RESPONSE to associated callback. 458 First we check the callbacks of pending requests. If no callback was found, 459 we check the completed requests, since responses could be received even for 460 older requests with \"done\" status." 461 (nrepl-dbind-response response (id) 462 (nrepl-log-message response 'response) 463 (let ((callback (or (gethash id nrepl-pending-requests) 464 (gethash id nrepl-completed-requests)))) 465 (if callback 466 (funcall callback response) 467 (error "[nREPL] No response handler with id %s found" id))))) 468 469 (defun nrepl-client-sentinel (process message) 470 "Handle sentinel events from PROCESS. 471 Notify MESSAGE and if the process is closed run `nrepl-disconnected-hook' 472 and kill the process buffer." 473 (if (string-match "deleted\\b" message) 474 (message "[nREPL] Connection closed") 475 (message "[nREPL] Connection closed unexpectedly (%s)" 476 (substring message 0 -1))) 477 (when (equal (process-status process) 'closed) 478 (when-let* ((client-buffer (process-buffer process))) 479 (sesman-remove-object 'CIDER nil client-buffer 480 (not (process-get process :keep-server)) 481 'no-error) 482 (nrepl--clear-client-sessions client-buffer) 483 (with-current-buffer client-buffer 484 (goto-char (point-max)) 485 (insert-before-markers 486 (propertize 487 (format "\n*** Closed on %s ***\n" (current-time-string)) 488 'face 'cider-repl-stderr-face)) 489 (run-hooks 'nrepl-disconnected-hook) 490 (let ((server-buffer nrepl-server-buffer)) 491 (when (and (buffer-live-p server-buffer) 492 (not (process-get process :keep-server))) 493 (setq nrepl-server-buffer nil) 494 (nrepl--maybe-kill-server-buffer server-buffer))))))) 495 496 497 ;;; Network 498 499 (defun nrepl--unix-connect (socket-file &optional no-error) 500 "If SOCKET-FILE is given, try to `make-network-process'. 501 If NO-ERROR is non-nil, show messages instead of throwing an error." 502 (if (not socket-file) 503 (unless no-error 504 (error "[nREPL] Socket file not provided")) 505 (message "[nREPL] Establishing unix socket connection to %s ..." socket-file) 506 (condition-case nil 507 (prog1 (list :proc (make-network-process :name "nrepl-connection" :buffer nil 508 :family 'local :service socket-file) 509 :host "local-unix-domain-socket" 510 :port socket-file 511 :socket-file socket-file) 512 (message "[nREPL] Unix socket connection to %s established" socket-file)) 513 (error (let ((msg (format "[nREPL] Unix socket connection to %s failed" socket-file))) 514 (if no-error 515 (message msg) 516 (error msg)) 517 nil))))) 518 519 (defun nrepl-connect (host port) 520 "Connect to the nREPL server identified by HOST and PORT. 521 For local hosts use a direct connection. For remote hosts, if 522 `nrepl-force-ssh-for-remote-hosts' is nil, attempt a direct connection 523 first. If `nrepl-force-ssh-for-remote-hosts' is non-nil or the direct 524 connection failed (and `nrepl-use-ssh-fallback-for-remote-hosts' is 525 non-nil), try to start a SSH tunneled connection. Return a plist of the 526 form (:proc PROC :host \"HOST\" :port PORT) that might contain additional 527 key-values depending on the connection type." 528 (let ((localp (if host 529 (nrepl-local-host-p host) 530 (not (file-remote-p default-directory))))) 531 (if localp 532 (nrepl--direct-connect (or host "localhost") port) 533 ;; we're dealing with a remote host 534 (if (and host (not nrepl-force-ssh-for-remote-hosts)) 535 (or (nrepl--direct-connect host port 'no-error) 536 ;; direct connection failed 537 ;; fallback to ssh tunneling if enabled 538 (and nrepl-use-ssh-fallback-for-remote-hosts 539 (message "[nREPL] Falling back to SSH tunneled connection ...") 540 (nrepl--ssh-tunnel-connect host port)) 541 ;; fallback is either not enabled or it failed as well 542 (if (and (null nrepl-use-ssh-fallback-for-remote-hosts) 543 (not localp)) 544 (error "[nREPL] Direct connection to %s:%s failed; try setting `nrepl-use-ssh-fallback-for-remote-hosts' to t" 545 host port) 546 (error "[nREPL] Cannot connect to %s:%s" host port))) 547 ;; `nrepl-force-ssh-for-remote-hosts' is non-nil 548 (nrepl--ssh-tunnel-connect host port))))) 549 550 (defun nrepl--direct-connect (host port &optional no-error) 551 "If HOST and PORT are given, try to `open-network-stream'. 552 If NO-ERROR is non-nil, show messages instead of throwing an error." 553 (if (not (and host port)) 554 (unless no-error 555 (unless host 556 (error "[nREPL] Host not provided")) 557 (unless port 558 (error "[nREPL] Port not provided"))) 559 (message "[nREPL] Establishing direct connection to %s:%s ..." host port) 560 (condition-case nil 561 (prog1 (list :proc (open-network-stream "nrepl-connection" nil host port) 562 :host host :port port) 563 (message "[nREPL] Direct connection to %s:%s established" host port)) 564 (error (let ((msg (format "[nREPL] Direct connection to %s:%s failed" host port))) 565 (if no-error 566 (message msg) 567 (error msg)) 568 nil))))) 569 570 (defun nrepl--ssh-tunnel-connect (host port) 571 "Connect to a remote machine identified by HOST and PORT through SSH tunnel." 572 (message "[nREPL] Establishing SSH tunneled connection to %s:%s ..." host port) 573 (let* ((current-buf (buffer-file-name)) 574 (tramp-file-regexp "/ssh:\\(.+@\\)?\\(.+?\\)\\(:\\|#\\).+") 575 (remote-dir (cond 576 ;; If current buffer is a TRAMP buffer and its host is 577 ;; the same as HOST, reuse its connection parameters for 578 ;; SSH tunnel. 579 ((and (string-match tramp-file-regexp current-buf) 580 (string= host (match-string 2 current-buf))) current-buf) 581 ;; Otherwise, if HOST was provided, use it for connection. 582 (host (format "/ssh:%s:" host)) 583 ;; Use default directory as fallback. 584 (t default-directory))) 585 (ssh (or (executable-find "ssh") 586 (error "[nREPL] Cannot locate 'ssh' executable"))) 587 (cmd (nrepl--ssh-tunnel-command ssh remote-dir port)) 588 (tunnel-buf (nrepl-tunnel-buffer-name 589 `((:host ,host) (:port ,port)))) 590 (tunnel (start-process-shell-command "nrepl-tunnel" tunnel-buf cmd))) 591 (process-put tunnel :waiting-for-port t) 592 (set-process-filter tunnel (nrepl--ssh-tunnel-filter port)) 593 (while (and (process-live-p tunnel) 594 (process-get tunnel :waiting-for-port)) 595 (accept-process-output nil 0.005)) 596 (if (not (process-live-p tunnel)) 597 (error "[nREPL] SSH port forwarding failed. Check the '%s' buffer" tunnel-buf) 598 (message "[nREPL] SSH port forwarding established to localhost:%s" port) 599 (let ((endpoint (nrepl--direct-connect "localhost" port))) 600 (thread-first 601 endpoint 602 (plist-put :tunnel tunnel) 603 (plist-put :remote-host host)))))) 604 605 (defun nrepl--ssh-tunnel-command (ssh dir port) 606 "Command string to open SSH tunnel to the host associated with DIR's PORT." 607 (with-parsed-tramp-file-name dir v 608 ;; this abuses the -v option for ssh to get output when the port 609 ;; forwarding is set up, which is used to synchronise on, so that 610 ;; the port forwarding is up when we try to connect. 611 (format-spec 612 "%s -v -N -L %p:localhost:%p %u'%h' %n" 613 `((?s . ,ssh) 614 (?p . ,port) 615 (?h . ,v-host) 616 (?u . ,(if v-user (format "-l '%s' " v-user) "")) 617 (?n . ,(if v-port (format "-p '%s' " v-port) "")))))) 618 619 (autoload 'comint-watch-for-password-prompt "comint" "(autoload).") 620 621 (defun nrepl--ssh-tunnel-filter (port) 622 "Return a process filter that waits for PORT to appear in process output." 623 (let ((port-string (format "LOCALHOST:%s" port))) 624 (lambda (proc string) 625 (when (string-match-p port-string string) 626 (process-put proc :waiting-for-port nil)) 627 (when (and (process-live-p proc) 628 (buffer-live-p (process-buffer proc))) 629 (with-current-buffer (process-buffer proc) 630 (let ((moving (= (point) (process-mark proc)))) 631 (save-excursion 632 (goto-char (process-mark proc)) 633 (insert string) 634 (set-marker (process-mark proc) (point)) 635 (comint-watch-for-password-prompt string)) 636 (if moving (goto-char (process-mark proc))))))))) 637 638 639 ;;; Client: Process Handling 640 641 (defun nrepl--kill-process (proc) 642 "Attempt to kill PROC tree. 643 On MS-Windows, using the standard API is highly likely to leave the child 644 processes still running in the background as orphans. As a workaround, an 645 attempt is made to delegate the task to the `taskkill` program, which comes 646 with windows since at least Windows XP, and fallback to the Emacs API if it 647 can't be found. 648 649 It is expected that the `(process-status PROC)` return value after PROC is 650 killed is `exit` when `taskkill` is used and `signal` otherwise." 651 (cond 652 ((and (eq system-type 'windows-nt) 653 (process-live-p proc) 654 (executable-find "taskkill")) 655 ;; try to use `taskkill` if available 656 (with-temp-buffer 657 (call-process-shell-command (format "taskkill /PID %s /T /F" (process-id proc)) 658 nil (buffer-name) ) 659 ;; useful for debugging. 660 ;;(message ":PROCESS-KILL-OUPUT %s" (buffer-string)) 661 )) 662 663 ((memq system-type '(cygwin windows-nt)) 664 ;; fallback, this is considered to work better than `kill-process` on 665 ;; MS-Windows. 666 (interrupt-process proc)) 667 668 (t (kill-process proc)))) 669 670 (defun nrepl-kill-server-buffer (server-buf) 671 "Kill SERVER-BUF and its process." 672 (when (buffer-live-p server-buf) 673 (let ((proc (get-buffer-process server-buf))) 674 (when (process-live-p proc) 675 (set-process-query-on-exit-flag proc nil) 676 (nrepl--kill-process proc)) 677 (kill-buffer server-buf)))) 678 679 (defun nrepl--maybe-kill-server-buffer (server-buf) 680 "Kill SERVER-BUF and its process. 681 Do not kill the server if there is a REPL connected to that server." 682 (when (buffer-live-p server-buf) 683 (with-current-buffer server-buf 684 ;; Don't kill if there is at least one REPL connected to it. 685 (when (not (seq-find (lambda (b) 686 (eq (buffer-local-value 'nrepl-server-buffer b) 687 server-buf)) 688 (buffer-list))) 689 (nrepl-kill-server-buffer server-buf))))) 690 691 (defun nrepl-start-client-process (&optional host port server-proc buffer-builder socket-file) 692 "Create new client process identified by either HOST and PORT or SOCKET-FILE. 693 If SOCKET-FILE is non-nil, it takes precedence. In remote buffers, HOST 694 and PORT are taken from the current tramp connection. SERVER-PROC must be 695 a running nREPL server process within Emacs. BUFFER-BUILDER is a function 696 of one argument (endpoint returned by `nrepl-connect') which returns a 697 client buffer. Return the newly created client process." 698 (let* ((endpoint (if socket-file 699 (nrepl--unix-connect (expand-file-name socket-file)) 700 (nrepl-connect host port))) 701 (client-proc (plist-get endpoint :proc)) 702 (builder (or buffer-builder (error "`buffer-builder' must be provided"))) 703 (client-buf (funcall builder endpoint))) 704 705 (set-process-buffer client-proc client-buf) 706 707 (set-process-filter client-proc #'nrepl-client-filter) 708 (set-process-sentinel client-proc #'nrepl-client-sentinel) 709 (set-process-coding-system client-proc 'utf-8-unix 'utf-8-unix) 710 711 (process-put client-proc :string-q (queue-create)) 712 (process-put client-proc :response-q (nrepl-response-queue)) 713 714 (with-current-buffer client-buf 715 (when-let* ((server-buf (and server-proc (process-buffer server-proc)))) 716 (setq nrepl-project-dir (buffer-local-value 'nrepl-project-dir server-buf) 717 nrepl-server-buffer server-buf)) 718 (setq nrepl-endpoint endpoint 719 nrepl-tunnel-buffer (when-let* ((tunnel (plist-get endpoint :tunnel))) 720 (process-buffer tunnel)) 721 nrepl-pending-requests (make-hash-table :test 'equal) 722 nrepl-completed-requests (make-hash-table :test 'equal))) 723 724 (with-current-buffer client-buf 725 (nrepl--init-client-sessions client-proc) 726 (nrepl--init-capabilities client-buf) 727 (run-hooks 'nrepl-connected-hook)) 728 729 client-proc)) 730 731 (defun nrepl--init-client-sessions (client) 732 "Initialize CLIENT connection nREPL sessions. 733 We create two client nREPL sessions per connection - a main session and a 734 tooling session. The main session is general purpose and is used for pretty 735 much every request that needs a session. The tooling session is used only 736 for functionality that's implemented in terms of the \"eval\" op, so that 737 eval requests for functionality like pretty-printing won't clobber the 738 values of *1, *2, etc." 739 (let* ((client-conn (process-buffer client)) 740 (response-main (nrepl-sync-request:clone client-conn)) 741 (response-tooling (nrepl-sync-request:clone client-conn t))) ; t for tooling 742 (nrepl-dbind-response response-main (new-session err) 743 (if new-session 744 (with-current-buffer client-conn 745 (setq nrepl-session new-session)) 746 (error "Could not create new session (%s)" err))) 747 (nrepl-dbind-response response-tooling (new-session err) 748 (if new-session 749 (with-current-buffer client-conn 750 (setq nrepl-tooling-session new-session)) 751 (error "Could not create new tooling session (%s)" err))))) 752 753 (defun nrepl--init-capabilities (conn-buffer) 754 "Store locally in CONN-BUFFER the capabilities of nREPL server." 755 (let ((description (nrepl-sync-request:describe conn-buffer))) 756 (nrepl-dbind-response description (ops versions aux) 757 (with-current-buffer conn-buffer 758 (setq nrepl-ops ops) 759 (setq nrepl-versions versions) 760 (setq nrepl-aux aux))))) 761 762 (defun nrepl--clear-client-sessions (conn-buffer) 763 "Clear information about nREPL sessions in CONN-BUFFER. 764 CONN-BUFFER refers to a (presumably) dead connection, 765 which we can eventually reuse." 766 (with-current-buffer conn-buffer 767 (setq nrepl-session nil) 768 (setq nrepl-tooling-session nil))) 769 770 771 ;;; Client: Response Handling 772 ;; After being decoded, responses (aka, messages from the server) are dispatched 773 ;; to handlers. Handlers are constructed with `nrepl-make-response-handler'. 774 775 (defvar nrepl-err-handler nil 776 "Evaluation error handler.") 777 778 (defun nrepl--mark-id-completed (id) 779 "Move ID from `nrepl-pending-requests' to `nrepl-completed-requests'. 780 It is safe to call this function multiple times on the same ID." 781 ;; FIXME: This should go away eventually when we get rid of 782 ;; pending-request hash table 783 (when-let* ((handler (gethash id nrepl-pending-requests))) 784 (puthash id handler nrepl-completed-requests) 785 (remhash id nrepl-pending-requests))) 786 787 (declare-function cider-repl--emit-interactive-output "cider-repl") 788 (defun nrepl-notify (msg type) 789 "Handle \"notification\" server request. 790 MSG is a string to be displayed. TYPE is the type of the message. All 791 notifications are currently displayed with `message' function and emitted 792 to the REPL." 793 (let* ((face (pcase type 794 ((or "message" `nil) 'font-lock-builtin-face) 795 ("warning" 'warning) 796 ("error" 'error))) 797 (msg (if face 798 (propertize msg 'face face) 799 (format "%s: %s" (upcase type) msg)))) 800 (cider-repl--emit-interactive-output msg (or face 'font-lock-builtin-face)) 801 (message msg))) 802 803 (defvar cider-buffer-ns) 804 (defvar cider-print-quota) 805 (defvar cider-special-mode-truncate-lines) 806 (declare-function cider-need-input "cider-client") 807 (declare-function cider-set-buffer-ns "cider-mode") 808 809 (defun nrepl-make-response-handler (buffer value-handler stdout-handler 810 stderr-handler done-handler 811 &optional eval-error-handler 812 content-type-handler 813 truncated-handler) 814 "Make a response handler for connection BUFFER. 815 A handler is a function that takes one argument - response received from 816 the server process. The response is an alist that contains at least 'id' 817 and 'session' keys. Other standard response keys are 'value', 'out', 'err', 818 and 'status'. 819 820 The presence of a particular key determines the type of the response. For 821 example, if 'value' key is present, the response is of type 'value', if 822 'out' key is present the response is 'stdout' etc. 823 824 Depending on the type, the handler dispatches the appropriate value to one 825 of the supplied handlers: VALUE-HANDLER, STDOUT-HANDLER, STDERR-HANDLER, 826 DONE-HANDLER, EVAL-ERROR-HANDLER, CONTENT-TYPE-HANDLER, and 827 TRUNCATED-HANDLER. 828 829 Handlers are functions of the buffer and the value they handle, except for 830 the optional CONTENT-TYPE-HANDLER which should be a function of the buffer, 831 content, the content-type to be handled as a list `(type attrs)'. 832 833 If the optional EVAL-ERROR-HANDLER is nil, the default `nrepl-err-handler' 834 is used. If any of the other supplied handlers are nil nothing happens for 835 the corresponding type of response." 836 (lambda (response) 837 (nrepl-dbind-response response (content-type content-transfer-encoding body 838 value ns out err status id) 839 (when (buffer-live-p buffer) 840 (with-current-buffer buffer 841 (when (and ns (not (derived-mode-p 'clojure-mode))) 842 (cider-set-buffer-ns ns)))) 843 (cond ((and content-type content-type-handler) 844 (funcall content-type-handler buffer 845 (if (string= content-transfer-encoding "base64") 846 (base64-decode-string body) 847 body) 848 content-type)) 849 (value 850 (when value-handler 851 (funcall value-handler buffer value))) 852 (out 853 (when stdout-handler 854 (funcall stdout-handler buffer out))) 855 (err 856 (when stderr-handler 857 (funcall stderr-handler buffer err))) 858 (status 859 (when (and truncated-handler (member "nrepl.middleware.print/truncated" status)) 860 (let ((warning (format "\n... output truncated to %sB ..." 861 (file-size-human-readable cider-print-quota)))) 862 (funcall truncated-handler buffer warning))) 863 (when (member "notification" status) 864 (nrepl-dbind-response response (msg type) 865 (nrepl-notify msg type))) 866 (when (member "interrupted" status) 867 (message "Evaluation interrupted.")) 868 (when (member "eval-error" status) 869 (funcall (or eval-error-handler nrepl-err-handler))) 870 (when (member "namespace-not-found" status) 871 (message "Namespace `%s' not found." ns)) 872 (when (member "need-input" status) 873 (cider-need-input buffer)) 874 (when (member "done" status) 875 (nrepl--mark-id-completed id) 876 (when done-handler 877 (funcall done-handler buffer)))))))) 878 879 880 ;;; Client: Request Core API 881 882 ;; Requests are messages from an nREPL client (like CIDER) to an nREPL server. 883 ;; Requests can be asynchronous (sent with `nrepl-send-request') or 884 ;; synchronous (send with `nrepl-send-sync-request'). The request is a pair list 885 ;; of operation name and operation parameters. The core operations are described 886 ;; at https://github.com/nrepl/nrepl/blob/master/doc/ops.md. CIDER adds 887 ;; many more operations through nREPL middleware. See 888 ;; https://github.com/clojure-emacs/cider-nrepl#supplied-nrepl-middleware for 889 ;; the up-to-date list. 890 891 (defun nrepl-next-request-id (connection) 892 "Return the next request id for CONNECTION." 893 (with-current-buffer connection 894 (number-to-string (cl-incf nrepl-request-counter)))) 895 896 (defun nrepl-send-request (request callback connection &optional tooling) 897 "Send REQUEST and register response handler CALLBACK using CONNECTION. 898 REQUEST is a pair list of the form (\"op\" \"operation\" \"par1-name\" 899 \"par1\" ... ). See the code of `nrepl-request:clone', 900 `nrepl-request:stdin', etc. This expects that the REQUEST does not have a 901 session already in it. This code will add it as appropriate to prevent 902 connection/session drift. 903 Return the ID of the sent message. 904 Optional argument TOOLING Set to t if desiring the tooling session rather than 905 the standard session." 906 (with-current-buffer connection 907 (when-let* ((session (if tooling nrepl-tooling-session nrepl-session))) 908 (setq request (append request `("session" ,session)))) 909 (let* ((id (nrepl-next-request-id connection)) 910 (request (cons 'dict (lax-plist-put request "id" id))) 911 (message (nrepl-bencode request))) 912 (nrepl-log-message request 'request) 913 (puthash id callback nrepl-pending-requests) 914 (process-send-string nil message) 915 id))) 916 917 (defvar nrepl-ongoing-sync-request nil 918 "Dynamically bound to t while a sync request is ongoing.") 919 920 (declare-function cider-repl-emit-interactive-stderr "cider-repl") 921 (declare-function cider--render-stacktrace-causes "cider-eval") 922 923 (defun nrepl-send-sync-request (request connection &optional abort-on-input tooling) 924 "Send REQUEST to the nREPL server synchronously using CONNECTION. 925 Hold till final \"done\" message has arrived and join all response messages 926 of the same \"op\" that came along. 927 If ABORT-ON-INPUT is non-nil, the function will return nil at the first 928 sign of user input, so as not to hang the interface. 929 If TOOLING, use the tooling session rather than the standard session." 930 (let* ((time0 (current-time)) 931 (response (cons 'dict nil)) 932 (nrepl-ongoing-sync-request t) 933 status) 934 (nrepl-send-request request 935 (lambda (resp) (nrepl--merge response resp)) 936 connection 937 tooling) 938 (while (and (not (member "done" status)) 939 (not (and abort-on-input 940 (input-pending-p)))) 941 (setq status (nrepl-dict-get response "status")) 942 ;; If we get a need-input message then the repl probably isn't going 943 ;; anywhere, and we'll just timeout. So we forward it to the user. 944 (if (member "need-input" status) 945 (progn (cider-need-input (current-buffer)) 946 ;; If the used took a few seconds to respond, we might 947 ;; unnecessarily timeout, so let's reset the timer. 948 (setq time0 (current-time))) 949 ;; break out in case we don't receive a response for a while 950 (when (and nrepl-sync-request-timeout 951 (time-less-p 952 nrepl-sync-request-timeout 953 (time-subtract nil time0))) 954 (error "Sync nREPL request timed out %s after %s secs" request nrepl-sync-request-timeout))) 955 ;; Clean up the response, otherwise we might repeatedly ask for input. 956 (nrepl-dict-put response "status" (remove "need-input" status)) 957 (accept-process-output nil 0.01)) 958 ;; If we couldn't finish, return nil. 959 (when (member "done" status) 960 (nrepl-dbind-response response (ex err eval-error pp-stacktrace id) 961 (when (and ex err) 962 (cond (eval-error (funcall nrepl-err-handler)) 963 (pp-stacktrace (cider--render-stacktrace-causes 964 pp-stacktrace (remove "done" status))))) ;; send the error type 965 (when id 966 (with-current-buffer connection 967 (nrepl--mark-id-completed id))) 968 response)))) 969 970 (defun nrepl-request:stdin (input callback connection) 971 "Send a :stdin request with INPUT using CONNECTION. 972 Register CALLBACK as the response handler." 973 (nrepl-send-request `("op" "stdin" 974 "stdin" ,input) 975 callback 976 connection)) 977 978 (defun nrepl-request:interrupt (pending-request-id callback connection) 979 "Send an :interrupt request for PENDING-REQUEST-ID. 980 The request is dispatched using CONNECTION. 981 Register CALLBACK as the response handler." 982 (nrepl-send-request `("op" "interrupt" 983 "interrupt-id" ,pending-request-id) 984 callback 985 connection)) 986 987 (define-minor-mode cider-enlighten-mode nil 988 :lighter (cider-mode " light") 989 :global t) 990 991 (defun nrepl--eval-request (input &optional ns line column) 992 "Prepare :eval request message for INPUT. 993 NS provides context for the request. 994 If LINE and COLUMN are non-nil and current buffer is a file buffer, \"line\", 995 \"column\" and \"file\" are added to the message." 996 (nconc (and ns `("ns" ,ns)) 997 `("op" "eval" 998 "code" ,(substring-no-properties input)) 999 (when cider-enlighten-mode 1000 '("enlighten" "true")) 1001 (let ((file (or (buffer-file-name) (buffer-name)))) 1002 (when (and line column file) 1003 `("file" ,file 1004 "line" ,line 1005 "column" ,column))))) 1006 1007 (defun nrepl-request:eval (input callback connection &optional ns line column additional-params tooling) 1008 "Send the request INPUT and register the CALLBACK as the response handler. 1009 The request is dispatched via CONNECTION. If NS is non-nil, 1010 include it in the request. LINE and COLUMN, if non-nil, define the position 1011 of INPUT in its buffer. A CONNECTION uniquely determines two connections 1012 available: the standard interaction one and the tooling session. If the 1013 tooling is desired, set TOOLING to true. 1014 ADDITIONAL-PARAMS is a plist to be appended to the request message." 1015 (nrepl-send-request (append (nrepl--eval-request input ns line column) additional-params) 1016 callback 1017 connection 1018 tooling)) 1019 1020 (defun nrepl-sync-request:clone (connection &optional tooling) 1021 "Sent a :clone request to create a new client session. 1022 The request is dispatched via CONNECTION. 1023 Optional argument TOOLING Tooling is set to t if wanting the tooling session 1024 from CONNECTION." 1025 (nrepl-send-sync-request '("op" "clone") 1026 connection 1027 nil tooling)) 1028 1029 (defun nrepl-sync-request:close (connection) 1030 "Sent a :close request to close CONNECTION's SESSION." 1031 (nrepl-send-sync-request '("op" "close") connection) 1032 (nrepl-send-sync-request '("op" "close") connection nil t)) ;; close tooling session 1033 1034 (defun nrepl-sync-request:describe (connection) 1035 "Perform :describe request for CONNECTION and SESSION." 1036 (nrepl-send-sync-request '("op" "describe") 1037 connection)) 1038 1039 (defun nrepl-sync-request:ls-sessions (connection) 1040 "Perform :ls-sessions request for CONNECTION." 1041 (nrepl-send-sync-request '("op" "ls-sessions") connection)) 1042 1043 (defun nrepl-sync-request:ls-middleware (connection) 1044 "Perform :ls-middleware request for CONNECTION." 1045 (nrepl-send-sync-request '("op" "ls-middleware") connection)) 1046 1047 (defun nrepl-sync-request:eval (input connection &optional ns tooling) 1048 "Send the INPUT to the nREPL server synchronously. 1049 The request is dispatched via CONNECTION. 1050 If NS is non-nil, include it in the request 1051 If TOOLING is non-nil the evaluation is done using the tooling nREPL 1052 session." 1053 (nrepl-send-sync-request 1054 (nrepl--eval-request input ns) 1055 connection 1056 nil 1057 tooling)) 1058 1059 (defun nrepl-sessions (connection) 1060 "Get a list of active sessions on the nREPL server using CONNECTION." 1061 (nrepl-dict-get (nrepl-sync-request:ls-sessions connection) "sessions")) 1062 1063 (defun nrepl-middleware (connection) 1064 "Get a list of middleware on the nREPL server using CONNECTION." 1065 (nrepl-dict-get (nrepl-sync-request:ls-middleware connection) "middleware")) 1066 1067 1068 ;;; Server 1069 1070 ;; The server side process is started by `nrepl-start-server-process' and has a 1071 ;; very simple filter that pipes its output directly into its process buffer 1072 ;; (*nrepl-server*). The main purpose of this process is to start the actual 1073 ;; nrepl communication client (`nrepl-client-filter') when the message "nREPL 1074 ;; server started on port ..." is detected. 1075 1076 ;; internal variables used for state transfer between nrepl-start-server-process 1077 ;; and nrepl-server-filter. 1078 (defvar-local nrepl-on-port-callback nil) 1079 1080 (defun nrepl-server-p (buffer-or-process) 1081 "Return t if BUFFER-OR-PROCESS is an nREPL server." 1082 (let ((buffer (if (processp buffer-or-process) 1083 (process-buffer buffer-or-process) 1084 buffer-or-process))) 1085 (buffer-local-value 'nrepl-is-server buffer))) 1086 1087 (defun nrepl-start-server-process (directory cmd on-port-callback) 1088 "Start nREPL server process in DIRECTORY using shell command CMD. 1089 Return a newly created process. Set `nrepl-server-filter' as the process 1090 filter, which starts REPL process with its own buffer once the server has 1091 started. ON-PORT-CALLBACK is a function of one argument (server buffer) 1092 which is called by the process filter once the port of the connection has 1093 been determined." 1094 (let* ((default-directory (or directory default-directory)) 1095 (serv-buf (get-buffer-create 1096 (nrepl-server-buffer-name 1097 `(:project-dir ,default-directory))))) 1098 (with-current-buffer serv-buf 1099 (setq nrepl-is-server t 1100 nrepl-project-dir default-directory 1101 nrepl-server-command cmd 1102 nrepl-on-port-callback on-port-callback)) 1103 (let ((serv-proc (start-file-process-shell-command 1104 "nrepl-server" serv-buf cmd))) 1105 (set-process-filter serv-proc #'nrepl-server-filter) 1106 (set-process-sentinel serv-proc #'nrepl-server-sentinel) 1107 (set-process-coding-system serv-proc 'utf-8-unix 'utf-8-unix) 1108 (message "[nREPL] Starting server via %s" 1109 (propertize cmd 'face 'font-lock-keyword-face)) 1110 serv-proc))) 1111 1112 (defconst nrepl-listening-unix-address-regexp 1113 (rx 1114 (and "nREPL server listening on" (+ " ") 1115 "nrepl+unix:" (group-n 1 (+ not-newline))))) 1116 1117 (defconst nrepl-listening-inet-address-regexp 1118 (rx (or 1119 ;; standard 1120 (and "nREPL server started on port " (group-n 1 (+ (any "0-9")))) 1121 ;; babashka 1122 (and "Started nREPL server at " 1123 (group-n 2 (+? any)) ":" (group-n 1 (+ (any "0-9")))))) 1124 "A regexp to search an nREPL's stdout for the address it is listening on. 1125 1126 If it matches, the address components can be extracted using the following 1127 match groups: 1128 1 for the port, and 1129 2 for the host (babashka only).") 1130 1131 (defun cider--process-plist-put (proc prop val) 1132 "Change value in PROC's plist of PROP to VAL. 1133 Value is changed using `plist-put`, of which see." 1134 (thread-first 1135 proc 1136 (process-plist) 1137 (plist-put prop val) 1138 (thread-last (set-process-plist proc)))) 1139 1140 (defun nrepl-server-filter (process output) 1141 "Process nREPL server output from PROCESS contained in OUTPUT. 1142 1143 The PROCESS plist is updated as (non-exhaustive list): 1144 1145 :cider--nrepl-server-ready set to t when the server is successfully brought 1146 up." 1147 ;; In Windows this can be false: 1148 (let ((server-buffer (process-buffer process))) 1149 (when (buffer-live-p server-buffer) 1150 (with-current-buffer server-buffer 1151 ;; auto-scroll on new output 1152 (let ((moving (= (point) (process-mark process)))) 1153 (save-excursion 1154 (goto-char (process-mark process)) 1155 (insert output) 1156 (ansi-color-apply-on-region (process-mark process) (point)) 1157 (set-marker (process-mark process) (point))) 1158 (when moving 1159 (goto-char (process-mark process)) 1160 (when-let* ((win (get-buffer-window))) 1161 (set-window-point win (point))))) 1162 ;; detect the port the server is listening on from its output 1163 (when (null nrepl-endpoint) 1164 (let ((end (cond 1165 ((string-match nrepl-listening-unix-address-regexp output) 1166 (let ((path (match-string 1 output))) 1167 (message "[nREPL] server started on nrepl+unix:%s" path) 1168 (list :host "local-unix-domain-socket" 1169 :port path 1170 :socket-file path))) 1171 ((string-match nrepl-listening-inet-address-regexp output) 1172 (let ((host (or (match-string 2 output) 1173 (file-remote-p default-directory 'host) 1174 "localhost")) 1175 (port (string-to-number (match-string 1 output)))) 1176 (message "[nREPL] server started on %s" port) 1177 (list :host host :port port)))))) 1178 (when end 1179 (setq nrepl-endpoint end) 1180 (cider--process-plist-put process :cider--nrepl-server-ready t) 1181 (when nrepl-on-port-callback 1182 (funcall nrepl-on-port-callback (process-buffer process)))))))))) 1183 1184 (defmacro emacs-bug-46284/when-27.1-windows-nt (&rest body) 1185 "Only evaluate BODY when Emacs bug #46284 has been detected." 1186 (when (and (eq system-type 'windows-nt) 1187 (string= emacs-version "27.1")) 1188 (cons 'progn body))) 1189 1190 1191 (declare-function cider--close-connection "cider-connection") 1192 (defun nrepl-server-sentinel (process event) 1193 "Handle nREPL server PROCESS EVENT. 1194 On a fatal EVENT, attempt to close any open client connections, and signal 1195 an `error' if the nREPL PROCESS exited because it couldn't start up." 1196 ;; only interested on fatal signals. 1197 (when (not (process-live-p process)) 1198 (emacs-bug-46284/when-27.1-windows-nt 1199 ;; There is a bug in emacs 27.1 (since fixed) that sets all EVENT 1200 ;; descriptions for signals to "unknown signal". We correct this by 1201 ;; resetting it back to its canonical value. 1202 (when (eq (process-status process) 'signal) 1203 (cl-case (process-exit-status process) 1204 ;; SIGHUP==1 emacs nt/inc/ms-w32.h 1205 (1 (setq event "Hangup")) 1206 ;; SIGINT==2 x86_64-w64-mingw32/include/signal.h 1207 (2 (setq event "Interrupt")) 1208 ;; SIGKILL==9 emacs nt/inc/ms-w32.h 1209 (9 (setq event "Killed"))))) 1210 (let* ((server-buffer (process-buffer process)) 1211 (clients (seq-filter (lambda (b) 1212 (eq (buffer-local-value 'nrepl-server-buffer b) 1213 server-buffer)) 1214 (buffer-list)))) 1215 ;; close any known open client connections 1216 (mapc #'cider--close-connection clients) 1217 1218 (if (process-get process :cider--nrepl-server-ready) 1219 (progn 1220 (when server-buffer (kill-buffer server-buffer)) 1221 (message "nREPL server exited.")) 1222 (let ((problem (when (and server-buffer (buffer-live-p server-buffer)) 1223 (with-current-buffer server-buffer 1224 (buffer-substring (point-min) (point-max)))))) 1225 (error "Could not start nREPL server: %s (%S)" problem (string-trim event))))))) 1226 1227 1228 ;;; Messages 1229 1230 (defcustom nrepl-log-messages nil 1231 "If non-nil, log protocol messages to an nREPL messages buffer. 1232 This is extremely useful for debug purposes, as it allows you to inspect 1233 the communication between Emacs and an nREPL server. Enabling the logging 1234 might have a negative impact on performance, so it's not recommended to 1235 keep it enabled unless you need to debug something." 1236 :type 'boolean 1237 :safe #'booleanp) 1238 1239 (defconst nrepl-message-buffer-max-size 1000000 1240 "Maximum size for the nREPL message buffer. 1241 Defaults to 1000000 characters, which should be an insignificant 1242 memory burden, while providing reasonable history.") 1243 1244 (defconst nrepl-message-buffer-reduce-denominator 4 1245 "Divisor by which to reduce message buffer size. 1246 When the maximum size for the nREPL message buffer is exceeded, the size of 1247 the buffer is reduced by one over this value. Defaults to 4, so that 1/4 1248 of the buffer is removed, which should ensure the buffer's maximum is 1249 reasonably utilized, while limiting the number of buffer shrinking 1250 operations.") 1251 1252 (defvar nrepl-messages-mode-map 1253 (let ((map (make-sparse-keymap))) 1254 (define-key map (kbd "n") #'next-line) 1255 (define-key map (kbd "p") #'previous-line) 1256 (define-key map (kbd "TAB") #'forward-button) 1257 (define-key map (kbd "RET") #'nrepl-log-expand-button) 1258 (define-key map (kbd "e") #'nrepl-log-expand-button) 1259 (define-key map (kbd "E") #'nrepl-log-expand-all-buttons) 1260 (define-key map (kbd "<backtab>") #'backward-button) 1261 map)) 1262 1263 (define-derived-mode nrepl-messages-mode special-mode "nREPL Messages" 1264 "Major mode for displaying nREPL messages. 1265 1266 \\{nrepl-messages-mode-map}" 1267 (when cider-special-mode-truncate-lines 1268 (setq-local truncate-lines t)) 1269 (setq-local sesman-system 'CIDER) 1270 (setq-local electric-indent-chars nil) 1271 (setq-local comment-start ";") 1272 (setq-local comment-end "") 1273 (setq-local paragraph-start "(-->\\|(<--") 1274 (setq-local paragraph-separate "(<--")) 1275 1276 (defun nrepl-decorate-msg (msg type) 1277 "Decorate nREPL MSG according to its TYPE." 1278 (pcase type 1279 (`request (cons '--> (cdr msg))) 1280 (`response (cons '<-- (cdr msg))))) 1281 1282 (defun nrepl-log-message (msg type) 1283 "Log the nREPL MSG. 1284 TYPE is either request or response. The message is logged to a buffer 1285 described by `nrepl-message-buffer-name-template'." 1286 (when nrepl-log-messages 1287 ;; append a time-stamp to the message before logging it 1288 ;; the time-stamps are quite useful for debugging 1289 (setq msg (cons (car msg) 1290 (lax-plist-put (cdr msg) "time-stamp" 1291 (format-time-string "%Y-%m-%0d %H:%M:%S.%N")))) 1292 (with-current-buffer (nrepl-messages-buffer (current-buffer)) 1293 (setq buffer-read-only nil) 1294 (when (> (buffer-size) nrepl-message-buffer-max-size) 1295 (goto-char (/ (buffer-size) nrepl-message-buffer-reduce-denominator)) 1296 (re-search-forward "^(" nil t) 1297 (delete-region (point-min) (- (point) 1))) 1298 (goto-char (point-max)) 1299 (nrepl-log-pp-object (nrepl-decorate-msg msg type) 1300 (nrepl-log--message-color (lax-plist-get (cdr msg) "id")) 1301 t) 1302 (when-let* ((win (get-buffer-window))) 1303 (set-window-point win (point-max))) 1304 (setq buffer-read-only t)))) 1305 1306 (defun nrepl-toggle-message-logging () 1307 "Toggle the value of `nrepl-log-messages' between nil and t. 1308 1309 This in effect enables or disables the logging of nREPL messages." 1310 (interactive) 1311 (setq nrepl-log-messages (not nrepl-log-messages)) 1312 (if nrepl-log-messages 1313 (message "nREPL message logging enabled") 1314 (message "nREPL message logging disabled"))) 1315 1316 (defcustom nrepl-message-colors 1317 '("red" "brown" "coral" "orange" "green" "deep sky blue" "blue" "dark violet") 1318 "Colors used in the messages buffer." 1319 :type '(repeat color)) 1320 1321 (defun nrepl-log-expand-button (&optional button) 1322 "Expand the objects hidden in BUTTON's :nrepl-object property. 1323 BUTTON defaults the button at point." 1324 (interactive) 1325 (if-let* ((button (or button (button-at (point))))) 1326 (let* ((start (overlay-start button)) 1327 (end (overlay-end button)) 1328 (obj (overlay-get button :nrepl-object)) 1329 (inhibit-read-only t)) 1330 (save-excursion 1331 (goto-char start) 1332 (delete-overlay button) 1333 (delete-region start end) 1334 (nrepl-log-pp-object obj) 1335 (delete-char -1))) 1336 (error "No button at point"))) 1337 1338 (defun nrepl-log-expand-all-buttons () 1339 "Expand all buttons in nREPL log buffer." 1340 (interactive) 1341 (if (not (eq major-mode 'nrepl-messages-mode)) 1342 (user-error "Not in a `nrepl-messages-mode'") 1343 (save-excursion 1344 (let* ((pos (point-min)) 1345 (button (next-button pos))) 1346 (while button 1347 (setq pos (overlay-start button)) 1348 (nrepl-log-expand-button button) 1349 (setq button (next-button pos))))))) 1350 1351 (defun nrepl-log--expand-button-mouse (event) 1352 "Expand the text hidden under overlay button. 1353 EVENT gives the button position on window." 1354 (interactive "e") 1355 (pcase (elt event 1) 1356 (`(,window ,_ ,_ ,_ ,_ ,point . ,_) 1357 (with-selected-window window 1358 (nrepl-log-expand-button (button-at point)))))) 1359 1360 (defun nrepl-log-insert-button (label object) 1361 "Insert button with LABEL and :nrepl-object property as OBJECT." 1362 (insert-button label 1363 :nrepl-object object 1364 'action #'nrepl-log-expand-button 1365 'face 'link 1366 'help-echo "RET: Expand object." 1367 ;; Workaround for bug#1568 (don't use local-map here; it 1368 ;; overwrites major mode map.) 1369 'keymap `(keymap (mouse-1 . nrepl-log--expand-button-mouse))) 1370 (insert "\n")) 1371 1372 (defun nrepl-log--message-color (id) 1373 "Return the color to use when pretty-printing the nREPL message with ID. 1374 If ID is nil, return nil." 1375 (when id 1376 (thread-first 1377 (string-to-number id) 1378 (mod (length nrepl-message-colors)) 1379 (nth nrepl-message-colors)))) 1380 1381 (defun nrepl-log--pp-listlike (object &optional foreground button) 1382 "Pretty print nREPL list like OBJECT. 1383 FOREGROUND and BUTTON are as in `nrepl-log-pp-object'." 1384 (cl-flet ((color (str) 1385 (propertize str 'face 1386 (append '(:weight ultra-bold) 1387 (when foreground `(:foreground ,foreground)))))) 1388 (let ((head (format "(%s" (car object)))) 1389 (insert (color head)) 1390 (if (null (cdr object)) 1391 (insert ")\n") 1392 (let* ((indent (+ 2 (- (current-column) (length head)))) 1393 (sorted-pairs (sort (seq-partition (cl-copy-list (cdr object)) 2) 1394 (lambda (a b) 1395 (string< (car a) (car b))))) 1396 (name-lengths (seq-map (lambda (pair) (length (car pair))) sorted-pairs)) 1397 (longest-name (seq-max name-lengths)) 1398 ;; Special entries are displayed first 1399 (specialq (lambda (pair) (member (car pair) '("id" "op" "session" "time-stamp")))) 1400 (special-pairs (seq-filter specialq sorted-pairs)) 1401 (not-special-pairs (seq-remove specialq sorted-pairs)) 1402 (all-pairs (seq-concatenate 'list special-pairs not-special-pairs)) 1403 (sorted-object (apply #'seq-concatenate 'list all-pairs))) 1404 (insert "\n") 1405 (cl-loop for l on sorted-object by #'cddr 1406 do (let ((indent-str (make-string indent ?\s)) 1407 (name-str (propertize (car l) 'face 1408 ;; Only highlight top-level keys. 1409 (unless (eq (car object) 'dict) 1410 'font-lock-keyword-face))) 1411 (spaces-str (make-string (- longest-name (length (car l))) ?\s))) 1412 (insert (format "%s%s%s " indent-str name-str spaces-str)) 1413 (nrepl-log-pp-object (cadr l) nil button))) 1414 (when (eq (car object) 'dict) 1415 (delete-char -1)) 1416 (insert (color ")\n"))))))) 1417 1418 (defun nrepl-log-pp-object (object &optional foreground button) 1419 "Pretty print nREPL OBJECT, delimited using FOREGROUND. 1420 If BUTTON is non-nil, try making a button from OBJECT instead of inserting 1421 it into the buffer." 1422 (let ((min-dict-fold-size 1) 1423 (min-list-fold-size 10) 1424 (min-string-fold-size 60)) 1425 (if-let* ((head (car-safe object))) 1426 ;; list-like objects 1427 (cond 1428 ;; top level dicts (always expanded) 1429 ((memq head '(<-- -->)) 1430 (nrepl-log--pp-listlike object foreground button)) 1431 ;; inner dicts 1432 ((eq head 'dict) 1433 (if (and button (> (length object) min-dict-fold-size)) 1434 (nrepl-log-insert-button "(dict ...)" object) 1435 (nrepl-log--pp-listlike object foreground button))) 1436 ;; lists 1437 (t 1438 (if (and button (> (length object) min-list-fold-size)) 1439 (nrepl-log-insert-button (format "(%s ...)" (prin1-to-string head)) object) 1440 (pp object (current-buffer))))) 1441 ;; non-list objects 1442 (if (stringp object) 1443 (if (and button (> (length object) min-string-fold-size)) 1444 (nrepl-log-insert-button (format "\"%s...\"" (substring object 0 min-string-fold-size)) object) 1445 (insert (prin1-to-string object) "\n")) 1446 (pp object (current-buffer)) 1447 (insert "\n"))))) 1448 1449 (declare-function cider--gather-connect-params "cider-connection") 1450 (defun nrepl-messages-buffer (conn) 1451 "Return or create the buffer for CONN. 1452 The default buffer name is *nrepl-messages connection*." 1453 (with-current-buffer conn 1454 (or (and (buffer-live-p nrepl-messages-buffer) 1455 nrepl-messages-buffer) 1456 (setq nrepl-messages-buffer 1457 (let ((buffer (get-buffer-create 1458 (nrepl-messages-buffer-name 1459 (cider--gather-connect-params))))) 1460 (with-current-buffer buffer 1461 (buffer-disable-undo) 1462 (nrepl-messages-mode) 1463 buffer)))))) 1464 1465 (defun nrepl-error-buffer () 1466 "Return or create the buffer. 1467 The default buffer name is *nrepl-error*." 1468 (or (get-buffer nrepl-error-buffer-name) 1469 (let ((buffer (get-buffer-create nrepl-error-buffer-name))) 1470 (with-current-buffer buffer 1471 (buffer-disable-undo) 1472 (nrepl--ensure-fundamental-mode) 1473 buffer)))) 1474 1475 (defun nrepl-log-error (msg) 1476 "Log the given MSG to the buffer given by `nrepl-error-buffer'." 1477 (with-current-buffer (nrepl-error-buffer) 1478 (setq buffer-read-only nil) 1479 (goto-char (point-max)) 1480 (insert msg) 1481 (when-let* ((win (get-buffer-window))) 1482 (set-window-point win (point-max))) 1483 (setq buffer-read-only t))) 1484 1485 (make-obsolete 'nrepl-default-client-buffer-builder nil "0.18") 1486 1487 (provide 'nrepl-client) 1488 1489 ;;; nrepl-client.el ends here