;;; nrepl-client.el --- Client for Clojure nREPL -*- lexical-binding: t -*- ;; Copyright © 2012-2014 Tim King, Phil Hagelberg ;; Copyright © 2013-2014 Bozhidar Batsov, Hugo Duncan, Steve Purcell ;; ;; Author: Tim King ;; Phil Hagelberg ;; Bozhidar Batsov ;; Hugo Duncan ;; Steve Purcell ;; ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;; ;; This file is not part of GNU Emacs. ;; ;;; Commentary: ;; ;; Provides an Emacs Lisp client to connect to Clojure nREPL servers. ;; ;; A connection is an abstract idea of the communication between Emacs (client) ;; and nREPL server. On Emacs side connections are represented by two running ;; processes. The two processes are the server process and client process. Each ;; of these is represented by it's own process buffer, filter and sentinel. ;; ;; The nREPL communication process can be broadly represented as follows: ;; ;; 1) Server process is started as an Emacs subprocess (usually by ;; `cider-jack-in') ;; ;; 2) Server's process filter (`nrepl-server-filter') detects the connection ;; port from the first plain text response from server and starts ;; communication process as another Emacs subprocess. This is the nREPL ;; client process (`nrepl-client-filter'). All requests and responses ;; handling happen through this client connection. ;; ;; 3) Requests are sent by `nrepl-send-request' and ;; `nrepl-send-sync-request'. Request is simply a list containing a ;; requested operation name and the parameters required by the ;; operation. Each request has an associated callback that is called once ;; the response for the request has arrived. Besides the above functions ;; there are specialized request senders for each type of common ;; operations. Examples are `nrepl-request:eval', `nrepl-request:clone', ;; `nrepl-request:describe'. ;; ;; 4) Responses from the server are decoded in `nrepl-client-filter' and are ;; physically represented by alists whose structure depends on the type of ;; the response. After having been decoded, the data from the response is ;; passed over to the callback that was registered by the original ;; request. ;; ;; Please see the comments in dedicated sections of this file for more detailed ;; description. ;;; Code: (require 'dash) (require 'thingatpt) (require 'etags) (require 'ansi-color) (require 'ewoc) (require 'cl-lib) (require 'cider-util) (require 'queue) ;;; Custom (defgroup nrepl nil "Interaction with the Clojure nREPL Server." :prefix "nrepl-" :group 'applications) (defcustom nrepl-buffer-name-separator " " "Used in constructing the REPL buffer name. The `nrepl-buffer-name-separator' separates cider-repl from the project name." :type '(string) :group 'nrepl) (defcustom nrepl-buffer-name-show-port nil "Show the connection port in the nrepl REPL buffer name, if set to t." :type 'boolean :group 'nrepl) (defcustom nrepl-connected-hook nil "List of functions to call when connecting to the nREPL server." :type 'hook :group 'nrepl) (defcustom nrepl-disconnected-hook nil "List of functions to call when disconnected from the nREPL server." :type 'hook :group 'nrepl) (defcustom nrepl-file-loaded-hook nil "List of functions to call when a load file has completed." :type 'hook :group 'nrepl) (defcustom nrepl-host "127.0.0.1" "The default hostname (or IP address) to connect to." :type 'string :group 'nrepl) (defcustom nrepl-port nil "The default port to connect to." :type 'string :group 'nrepl) (defcustom nrepl-sync-request-timeout 10 "The number of seconds to wait for a sync response. Setting this to nil disables the timeout functionality." :type 'integer :group 'nrepl) (defcustom nrepl-connection-endpoint 'nrepl-connection-ssh-tunnel "A function that is called to determine command that will be run once an nrepl server process is running. Used to set up an ssh tunnel on remote connections. The arguments are dir and port. The return value should be an `plist` of the form (:proc-buffer-name \"*buf*\" :hostname \"hostname\" :port 1234)" :type 'function :group 'nrepl) (defcustom nrepl-hide-special-buffers nil "Control the display of some special buffers in buffer switching commands. When true some special buffers like the connection and the server buffer will be hidden." :type 'boolean :group 'nrepl) ;;; nREPL Buffer Names (defconst nrepl-repl-buffer-name-template "*cider-repl%s*") (defconst nrepl-connection-buffer-name-template "*nrepl-connection%s*") (defconst nrepl-server-buffer-name-template "*nrepl-server%s*") (defconst nrepl-on-connection-buffer-name-template "*nrepl-on-connection%s*") (defun nrepl-format-buffer-name-template (buffer-name-template designation) "Apply the DESIGNATION to the corresponding BUFFER-NAME-TEMPLATE." (format buffer-name-template (if (> (length designation) 0) (concat nrepl-buffer-name-separator designation) ""))) (defun nrepl-make-buffer-name (buffer-name-template &optional project-dir host port) "Generate a buffer name using BUFFER-NAME-TEMPLATE. If not supplied PROJECT-DIR, PORT and HOST default to the buffer local value of the `nrepl-project-dir' and `nrepl-endpoint'. The name will include the project name if available or the endpoint host if it is not. The name will also include the connection port if `nrepl-buffer-name-show-port' is true." (generate-new-buffer-name (let ((project-name (nrepl--project-name (or project-dir nrepl-project-dir))) (nrepl-proj-port (or port (cadr nrepl-endpoint)))) (nrepl-format-buffer-name-template buffer-name-template (concat (if project-name project-name (or host (car nrepl-endpoint))) (if (and nrepl-proj-port nrepl-buffer-name-show-port) (format ":%s" nrepl-proj-port) "")))))) (defun nrepl--make-hidden-name (buffer-name) "Apply a prefix to BUFFER-NAME that will hide the buffer." (concat (if nrepl-hide-special-buffers " " "") buffer-name)) (defun nrepl-connection-buffer-name (&optional project-dir host port) "Return the name of the connection buffer. PROJECT-DIR, HOST and PORT are as in `/nrepl-make-buffer-name'." (nrepl--make-hidden-name (nrepl-make-buffer-name nrepl-connection-buffer-name-template project-dir host port))) (defun nrepl-server-buffer-name (&optional project-dir host port) "Return the name of the server buffer. PROJECT-DIR, HOST and PORT are as in `nrepl-make-buffer-name'." (nrepl--make-hidden-name (nrepl-make-buffer-name nrepl-server-buffer-name-template project-dir host port))) (defun nrepl-on-connection-buffer-name (&optional project-dir host port) "Return the name of the on-connection buffer. PROJECT-DIR, HOST and PORT are as in `nrepl-make-buffer-name'." (nrepl--make-hidden-name (nrepl-make-buffer-name nrepl-on-connection-buffer-name-template project-dir host port))) ;;; Buffer Local Declarations ;; These variables are used to track the state of nREPL connections (defvar-local nrepl-connection-buffer nil) (defvar-local nrepl-server-buffer nil) (defvar-local nrepl-repl-buffer nil) (defvar-local nrepl-endpoint nil) (defvar-local nrepl-project-dir nil) (defvar-local nrepl-on-connection-buffer nil) (defvar-local nrepl-session nil "Current nREPL session id.") (defvar-local nrepl-tooling-session nil "Current nREPL tooling session id. To be used for tooling calls (i.e. completion, eldoc, etc)") (defvar-local nrepl-request-counter 0 "Continuation serial number counter.") (defvar-local nrepl-pending-requests (make-hash-table :test 'equal)) (defvar-local nrepl-completed-requests (make-hash-table :test 'equal)) (defvar-local nrepl-buffer-ns "user" "Current Clojure namespace of this buffer.") (defvar-local nrepl-last-sync-response nil "Result of the last sync request.") (defvar-local nrepl-last-sync-request-timestamp nil "The time when the last sync request was initiated.") (defvar-local nrepl-ops nil "Available nREPL server ops (from describe).") (defvar-local nrepl-versions nil "Version information received from the describe op.") ;;; nREPL dict (defun nrepl-dict-p (object) "Return t if OBJECT is a nREPL dict." (and (listp object) (eq (car object) 'dict))) (defun nrepl-dict-get (dict key) "Get from DICT value associated with KEY. If dict is nil, return nil." (when dict (if (nrepl-dict-p dict) (lax-plist-get (cdr dict) key) (error "Not a nREPL dict object: %s" dict)))) (defun nrepl-dict-put (dict key value) "Associate in DICT, KEY to VALUE. Return new dict. Dict is modified by side effects." (if (null dict) (list 'dict key value) (if (not (nrepl-dict-p dict)) (error "Not a nREPL dict object: %s" dict) (setcdr dict (lax-plist-put (cdr dict) key value)) dict))) (defun nrepl-dict-keys (dict) "Return all the keys in the nREPL dict." (if (nrepl-dict-p dict) (cl-loop for l on (cdr dict) by #'cddr collect (car l)) (error "Not a nREPL dict."))) (defun nrepl--cons (car list-or-dict) "Generic cons of CAR to LIST-OR-DICT." (if (eq (car list-or-dict) 'dict) (cons 'dict (cons car (cdr list-or-dict))) (cons car list-or-dict))) (defun nrepl--nreverse (list-or-dict) "Generic `nreverse' which works on LIST-OR-DICT." (if (eq (car list-or-dict) 'dict) (cons 'dict (nreverse (cdr list-or-dict))) (nreverse list-or-dict))) (defun nrepl--push (obj stack) "Cons OBJ to the top element of the STACK." ;; stack is assumed to be a list (if (eq (caar stack) 'dict) (cons (cons 'dict (cons obj (cdar stack))) (cdr stack)) (cons (if (null stack) obj (cons obj (car stack))) (cdr stack)))) ;;; Bencode (cl-defstruct (nrepl-response-queue (:include queue) (:constructor nil) (:constructor nrepl-response-queue (&optional stub))) stub) (put 'nrepl-response-queue 'function-documentation "Create queue object used by nREPL to store decoded server requests. The STUB slot stores a stack of nested, incompletely parsed objects.") (defun nrepl--bdecode-list (&optional stack) "Decode a bencode list or dict starting at point. STACK is as in `nrepl--bdecode-1'." ;; skip leading l or d (forward-char 1) (let* ((istack (nrepl--bdecode-1 stack)) (pos0 (point)) (info (car istack))) (while (null info) (setq istack (nrepl--bdecode-1 (cdr istack)) pos0 (point) info (car istack))) (cond ((eq info :e) (cons nil (cdr istack))) ((eq info :stub) (goto-char pos0) istack) (t istack)))) (defun nrepl--bdecode-1 (&optional stack) "Decode one elementary bencode object starting at point. Bencoded object is either list, dict, integer or string. See http://en.wikipedia.org/wiki/Bencode#Encoding_algorithm for the encoding rules. STACK is a list of so far decoded components of the current message. Car of STACK is the innermost incompletely decoded object. The algorithm pops this list when inner object was completely decoded or grows it by one when new list or dict was encountered. The returned value is of the form (INFO . STACK) where INFO is :stub, nil, :end or :eob and STACK is either an incomplete parsing state as above (INFO is :stub, nil or :eob) or a list of one component representing the completely decoded message (INFO is :end). INFO is nil when an elementary non-root object was successfully decoded. INFO is :end when this object is a root list or dict." (cond ;; list ((eq (char-after) ?l) (nrepl--bdecode-list (cons () stack))) ;; dict ((eq (char-after) ?d) (nrepl--bdecode-list (cons '(dict) stack))) ;; end of a list or a dict ((eq (char-after) ?e) (forward-char 1) (cons (if (cdr stack) :e :end) (nrepl--push (nrepl--nreverse (car stack)) (cdr stack)))) ;; string ((looking-at "\\([0-9]+\\):") (let ((pos0 (point)) (beg (goto-char (match-end 0))) (end (byte-to-position (+ (position-bytes (point)) (string-to-number (match-string 1)))))) (if (null end) (progn (goto-char pos0) (cons :stub stack)) (goto-char end) (cons nil (nrepl--push (buffer-substring-no-properties beg end) stack))))) ;; integer ((looking-at "i\\(-?[0-9]+\\)e") (goto-char (match-end 0)) (cons nil (nrepl--push (string-to-number (match-string 1)) stack))) ;; should happen in tests only as eobp is checked in nrepl-bdecode. ((eobp) (cons :eob stack)) ;; truncation in the middle of an integer or in 123: string prefix ((looking-at "[0-9i]") (cons :stub stack)) ;; else, throw a quiet error (t (message "Invalid bencode message detected. See %s buffer." nrepl-message-buffer-name) (nrepl-log-message (format "Decoder error at position %d ('%s'):" (point) (buffer-substring (point) (min (+ (point) 10) (point-max))))) (nrepl-log-message (buffer-string)) (ding) ;; Ensure loop break and clean queues' states in nrepl-bdecode: (goto-char (point-max)) (cons :end nil)))) (defun nrepl--bdecode-message (&optional stack) "Decode one full message starting at point. STACK is as in `nrepl--bdecode-1'. Return a cons (INFO . STACK)." (let* ((istack (nrepl--bdecode-1 stack)) (info (car istack)) (stack (cdr istack))) (while (or (null info) (eq info :e)) (setq istack (nrepl--bdecode-1 stack) info (car istack) stack (cdr istack))) istack)) (defun nrepl-bdecode (string-q &optional response-q) "Decode STRING-Q and place the results into RESPONSE-Q. STRING-Q is either a queue of strings or a string. RESPONSE-Q is a queue of server requests (nREPL dicts). STRING-Q and RESPONSE-Q are modified by side effects. Return a cons (STRING-Q . RESPONSE-Q) where STRING-Q is the original queue containing the remainder of the input strings which could not be decoded. RESPONSE-Q is the original queue with successfully decoded messages enqueued and with slot STUB containing a nested stack of an incompletely decoded message or nil if the strings were completely decoded." (with-temp-buffer (if (queue-p string-q) (while (queue-head string-q) (insert (queue-dequeue string-q))) (insert string-q) (setq string-q (queue-create))) (goto-char 1) (unless response-q (setq response-q (nrepl-response-queue))) (let ((istack (nrepl--bdecode-message (nrepl-response-queue-stub response-q)))) (while (and (eq (car istack) :end) (not (eobp))) (queue-enqueue response-q (cadr istack)) (setq istack (nrepl--bdecode-message))) (unless (eobp) (queue-enqueue string-q (buffer-substring (point) (point-max)))) (if (not (eq (car istack) :end)) (setf (nrepl-response-queue-stub response-q) (cdr istack)) (queue-enqueue response-q (cadr istack)) (setf (nrepl-response-queue-stub response-q) nil)) (cons string-q response-q)))) (defun nrepl-bencode (object) "Encode OBJECT with bencode. Integers, lists and nrepl-dicts are treated according to bencode specification. Everything else is encoded as string." (cond ((integerp object) (format "i%de" object)) ((nrepl-dict-p object) (format "d%se" (apply 'concat (-map 'nrepl-bencode (cdr object))))) ((listp object) (format "l%se" (apply 'concat (-map 'nrepl-bencode object)))) (t (format "%s:%s" (string-bytes object) object)))) ;;; Client: Process Filter (defun nrepl-client-filter (proc string) "Decode message(s) from PROC contained in STRING and dispatch them." ;; (nrepl-log-message string) (let ((string-q (process-get proc :string-q))) (queue-enqueue string-q string) ;; Start decoding only if the last letter is 'e' (when (eq ?e (aref string (1- (length string)))) (let ((response-q (process-get proc :response-q))) ;; (nrepl-log-message string-q) ;; (nrepl-log-message response-q) (nrepl-bdecode string-q response-q) (while (queue-head response-q) (nrepl--dispatch-response (queue-dequeue response-q))))))) (defun nrepl--dispatch-response (response) "Dispatch the RESPONSE to associated callback. First we check the callbacks of pending requests. If no callback was found, we check the completed requests, since responses could be received even for older requests with \"done\" status." (nrepl-dbind-response response (id) (nrepl-log-message response) (let ((callback (or (gethash id nrepl-pending-requests) (gethash id nrepl-completed-requests)))) (if callback (funcall callback response) (funcall (nrepl--make-default-handler) response))))) (defun nrepl-client-sentinel (process message) "Handle sentinel events from PROCESS. Display MESSAGE and if the process is closed kill the process buffer and run the hook `nrepl-disconnected-hook'." (message "nREPL connection closed: %s" message) (if (equal (process-status process) 'closed) (run-hooks 'nrepl-disconnected-hook))) ;;; Client: Initialization ;; `nrepl-start-client-process' is called from `nrepl-server-filter'. It ;; starts the client process described by `nrepl-client-filter' and ;; `nrepl-client-sentinel'. (defun nrepl-start-client-process (&optional directory host port replp server-proc) "Create new client process identified by DIRECTORY, HOST and PORT. If DIRECTORY is nil, use `default-directory'. If eitehr HOST or PORT are nil, pick them from the value returned by `nrepl-connection-endpoint'. If REPLP is non-nil create a client connection which is associated with a repl buffer. When non-nil, SERVER-PROC must be a running nrepl server process within Emacs. Return the newly created client connection process." (let* ((endpoint (if (functionp nrepl-connection-endpoint) (funcall nrepl-connection-endpoint directory port) (nrepl--default-endpoint directory port))) (directory (or directory default-directory)) (host (or host (plist-get endpoint :hostname))) (port (or port (plist-get endpoint :port))) (proc-buffer-name (plist-get endpoint :proc-buffer-name)) (server-buf (and server-proc (buffer-name (process-buffer server-proc)))) (client-buf (if replp (cider-repl-create directory host port) (nrepl-create-connection-buffer directory host port))) (client-proc (open-network-stream "nrepl" client-buf host port)) (nrepl-connection-dispatch client-buf)) (set-process-filter client-proc 'nrepl-client-filter) (set-process-sentinel client-proc 'nrepl-client-sentinel) (set-process-coding-system client-proc 'utf-8-unix 'utf-8-unix) (process-put client-proc :string-q (queue-create)) (process-put client-proc :response-q (nrepl-response-queue)) (with-current-buffer client-buf (when server-buf (setq nrepl-project-dir (buffer-local-value 'nrepl-project-dir (get-buffer server-buf)) nrepl-server-buffer server-buf)) (setq nrepl-endpoint `(,host ,port) ;; fixme: repl and connection buffers are the same thing nrepl-connection-buffer client-buf nrepl-repl-buffer (when replp client-buf) nrepl-on-connection-buffer proc-buffer-name)) (nrepl-make-connection-default client-buf) ;; Everything is set. We are ready to send requests. (nrepl-request:clone (nrepl--new-tooling-session-handler client-proc)) (nrepl-request:clone (nrepl--new-session-handler client-proc)) (when replp (nrepl-request:describe (nrepl--connection-buffer-init-handler client-buf t))) client-proc)) (defun nrepl--connection-buffer-init-handler (conn-buffer replp) "Return a handler to setup CONN-BUFFER as a connection buffer. If REPLP is non-nil, also initialize it as a REPL buffer." (lambda (response) (nrepl-dbind-response response (ops versions) (with-current-buffer conn-buffer (setq nrepl-ops ops) (setq nrepl-versions versions))) (when replp (cider-repl-init conn-buffer)) (cider--check-required-nrepl-ops) (cider--check-middleware-compatibility))) (defun nrepl--new-session-handler (process) "Create a new session handler for PROCESS." (lambda (response) (nrepl-dbind-response response (id new-session err) (remhash id nrepl-pending-requests) (if new-session (with-current-buffer (process-buffer process) (setq nrepl-session new-session)) (error "Could not create new session (%s)" err)) (run-hooks 'nrepl-connected-hook)))) (defun nrepl--new-tooling-session-handler (process) "Create a new tooling session handler for PROCESS." (lambda (response) (nrepl-dbind-response response (id new-session err) (if new-session (with-current-buffer (process-buffer process) (remhash id nrepl-pending-requests) (setq nrepl-tooling-session new-session)) (error "Could not create new tooling session (%s)" err))))) (defun nrepl--port-from-file (file) "Attempts to read port from a file named by FILE." (let* ((dir (nrepl-project-directory-for (nrepl-current-dir))) (f (expand-file-name file dir))) (when (file-exists-p f) (with-temp-buffer (insert-file-contents f) (buffer-string))))) (defun nrepl-default-port () "Attempt to read port from .nrepl-port or target/repl-port. Falls back to `nrepl-port' if not found." (or (nrepl--port-from-file ".nrepl-port") (nrepl--port-from-file "target/repl-port") nrepl-port)) ;;; Client: Response Handling ;; After being decoded, responses (aka, messages from the server) are dispatched ;; to handlers. Handlers are constructed with `nrepl-make-response-handler'. (defmacro nrepl-dbind-response (response keys &rest body) "Destructure an nREPL RESPONSE dict. Bind the value of the provided KEYS and execute BODY." `(let ,(cl-loop for key in keys collect `(,key (lax-plist-get (cdr ,response) ,(format "%s" key)))) ,@body)) (put 'nrepl-dbind-response 'lisp-indent-function 2) (defvar nrepl-err-handler 'cider-default-err-handler "Evaluation error handler.") (defun nrepl-make-response-handler (buffer value-handler stdout-handler stderr-handler done-handler &optional eval-error-handler) "Make a response handler for connection BUFFER. A handler is a function that takes one argument - response received from the server process. The response is an alist that contains at least 'id' and 'session' keys. Other standard response keys are 'value', 'out', 'err' and 'status'. The presence of a particular key determines the type of the response. For example, if 'value' key is present, the response is of type 'value', if 'out' key is present the response is 'stdout' etc. Depending on the typea, the handler dispatches the appropriate value to one of the supplied handlers: VALUE-HANDLER, STDOUT-HANDLER, STDERR-HANDLER, DONE-HANDLER, and EVAL-ERROR-HANDLER. If the optional EVAL-ERROR-HANDLER is nil, the default `nrepl-err-handler' is used. If any of the other supplied handlers are nil nothing happens for the coresponding type of response. When `nrepl-log-messages' is non-nil, *nrepl-messages* buffer contains server responses." (lambda (response) (nrepl-dbind-response response (value ns out err status id ex root-ex session) (cond (value (with-current-buffer buffer (when ns (setq nrepl-buffer-ns ns))) (when value-handler (funcall value-handler buffer value))) (out (when stdout-handler (funcall stdout-handler buffer out))) (err (when stderr-handler (funcall stderr-handler buffer err))) (status (when (member "interrupted" status) (message "Evaluation interrupted.")) (when (member "eval-error" status) (funcall (or eval-error-handler nrepl-err-handler) buffer ex root-ex session)) (when (member "namespace-not-found" status) (message "Namespace not found.")) (when (member "need-input" status) (cider-need-input buffer)) (when (member "done" status) (puthash id (gethash id nrepl-pending-requests) nrepl-completed-requests) (remhash id nrepl-pending-requests) (when done-handler (funcall done-handler buffer)))))))) (defun nrepl--make-default-handler () "Default handler which is invoked when no handler is found. Handles only stdout and stderr responses." (nrepl-make-response-handler (cider-current-repl-buffer) ;; VALUE '() ;; STDOUT (lambda (buffer out) ;; fixme: rename into emit-out-output (cider-repl-emit-output buffer out)) ;; STDERR (lambda (buffer err) (cider-repl-emit-err-output buffer err)) ;; DONE '())) ;;; Client: Request Handling ;; Requests are messages from an nREPL client (like CIDER) to an nREPL server. ;; Requests can be asynchronous (sent with `nrepl-send-request') or ;; synchronous (send with `nrepl-send-sync-request'). The request is a pair list ;; of operation name and operation parameters. The core operations are described ;; at https://github.com/clojure/tools.nrepl/blob/master/doc/ops.md. CIDER adds ;; many more operations through nREPL middleware. See ;; https://github.com/clojure-emacs/cider-nrepl#supplied-nrepl-middleware for ;; the up to date list. (defun nrepl-current-session () "Return the current session." (with-current-buffer (nrepl-current-connection-buffer) nrepl-session)) (defun nrepl-current-tooling-session () "Return the current tooling session." (with-current-buffer (nrepl-current-connection-buffer) nrepl-tooling-session)) (defun nrepl-next-request-id () "Return the next request id." (with-current-buffer (nrepl-current-connection-buffer) (number-to-string (cl-incf nrepl-request-counter)))) ;; asynchronous requests (defun nrepl-send-request (request callback) "Send REQUEST and register response handler CALLBACK. REQUEST is a pair list of the form (\"op\" \"operation\" \"par1-name\" \"par1\" ... ). See the code of `nrepl-request:clone', `nrepl-request:stdin', etc." (let* ((request-id (nrepl-next-request-id)) (request (append (list 'dict "id" request-id) request)) (message (nrepl-bencode request))) (nrepl-log-message request) (puthash request-id callback nrepl-pending-requests) (process-send-string (nrepl-current-connection-buffer) message))) (defun nrepl-request:clone (callback) "Sent a :clone request to create a new client session. Response will be handled by CALLBACK." (nrepl-send-request '("op" "clone") callback)) (defun nrepl-request:describe (callback) "Peform describe for the given server PROCESS." (nrepl-send-request (list "op" "describe") callback)) (defun nrepl-request:stdin (input callback) "Send a :stdin request with INPUT. Register CALLBACK as the response handler." (nrepl-send-request (list "op" "stdin" "stdin" input "session" (nrepl-current-session)) callback)) (defun nrepl-request:interrupt (pending-request-id callback) "Send an :interrupt request for PENDING-REQUEST-ID. Register CALLBACK as the response handler." (nrepl-send-request (list "op" "interrupt" "session" (nrepl-current-session) "interrupt-id" pending-request-id) callback)) (defun nrepl--make-eval-request (input &optional ns session) "Prepare :eval request message for INPUT in the context of NS ans SESSION." (append (and ns (list "ns" ns)) (list "op" "eval" "session" (or session (nrepl-current-session)) "code" input))) (defun nrepl-request:eval (input callback &optional ns session) "Send the request INPUT and register the CALLBACK as the response handler. If NS is non-nil, include it in the request. SESSION defaults to current session." (nrepl-send-request (nrepl--make-eval-request input ns session) callback)) ;; synchronous requests (defun nrepl-sync-request-handler (buffer) "Make a synchronous request handler for BUFFER." (nrepl-make-response-handler buffer (lambda (_buffer value) (setq nrepl-last-sync-response (plist-put nrepl-last-sync-response :value value))) (lambda (_buffer out) (let ((so-far (plist-get nrepl-last-sync-response :stdout))) (setq nrepl-last-sync-response (plist-put nrepl-last-sync-response :stdout (concat so-far out))))) (lambda (_buffer err) (let ((so-far (plist-get nrepl-last-sync-response :stderr))) (setq nrepl-last-sync-response (plist-put nrepl-last-sync-response :stderr (concat so-far err))))) (lambda (_buffer) (setq nrepl-last-sync-response (plist-put nrepl-last-sync-response :done t))))) (defun nrepl-send-sync-request (request) "Send REQUEST to the nREPL server synchronously (discouraged). The result is a plist with keys :value, :stderr and :stdout." (with-current-buffer (nrepl-current-connection-buffer) (setq nrepl-last-sync-response nil) (setq nrepl-last-sync-request-timestamp (current-time)) (nrepl-send-request request (nrepl-sync-request-handler (current-buffer))) (while (or (null nrepl-last-sync-response) (null (plist-get nrepl-last-sync-response :done))) (accept-process-output nil 0.01) ;; break out in case we don't receive a response for a while (when nrepl-sync-request-timeout (let ((seconds-ellapsed (cadr (time-subtract (current-time) nrepl-last-sync-request-timestamp)))) (when (> seconds-ellapsed nrepl-sync-request-timeout) (error "nREPL sync request timed out %s" request))))) nrepl-last-sync-response)) (defun nrepl-sync-request:eval (input &optional ns session) "Send the INPUT to the nREPL server synchronously. If NS is non-nil, include it in the request. SESSION defaults to current session." (nrepl-send-sync-request (nrepl--make-eval-request input ns session))) ;;; Server ;; The server side process is started by `nrepl-start-server-process' and has a ;; very simple filter that pipes its output directly into its process buffer ;; (*nrepl-server*). The main purpose of this process is to start the actual ;; nrepl communication client (`nrepl-client-filter') when the message "nREPL ;; server started on port ..." is detected. (defun nrepl-start-server-process (directory cmd) "Start nREPL server process in DIRECTORY using shell command CMD. Return a newly created process." (let* ((default-directory (or directory default-directory)) (serv-buf (get-buffer-create (generate-new-buffer-name (nrepl-server-buffer-name directory)))) (serv-proc (start-file-process-shell-command "nrepl-server" serv-buf cmd))) (set-process-filter serv-proc 'nrepl-server-filter) (set-process-sentinel serv-proc 'nrepl-server-sentinel) (set-process-coding-system serv-proc 'utf-8-unix 'utf-8-unix) (with-current-buffer serv-buf (setq nrepl-project-dir directory)) (message "Starting nREPL server via %s..." (propertize cmd 'face 'font-lock-keyword-face)) serv-proc)) (defun nrepl-server-filter (process output) "Process nREPL server output from PROCESS contained in OUTPUT." (with-current-buffer (process-buffer process) (save-excursion (goto-char (point-max)) (insert output))) (when (string-match "nREPL server started on port \\([0-9]+\\)" output) (let ((port (string-to-number (match-string 1 output)))) (message (format "nREPL server started on %s" port)) (with-current-buffer (process-buffer process) (let ((client-proc (nrepl-start-client-process default-directory nil port t process))) ;; fixme: Bad connection tracking system. There can be multiple client ;; connections per server (setq nrepl-connection-buffer (buffer-name (process-buffer client-proc)))))))) (defun nrepl-server-sentinel (process event) "Handle nREPL server PROCESS EVENT." (let* ((nrepl-buffer (process-buffer process)) (connection-buffer (buffer-local-value 'nrepl-connection-buffer nrepl-buffer)) (problem (if (and nrepl-buffer (buffer-live-p nrepl-buffer)) (with-current-buffer nrepl-buffer (buffer-substring (point-min) (point-max))) ""))) (when nrepl-buffer (kill-buffer nrepl-buffer)) (cond ((string-match "^killed" event) nil) ((string-match "^hangup" event) (when connection-buffer (nrepl-close connection-buffer))) ((string-match "Wrong number of arguments to repl task" problem) (error "Leiningen 2.x is required by CIDER")) (t (error "Could not start nREPL server: %s" problem))))) (defun nrepl-connection-ssh-tunnel (dir port) "Return an endpoint for SSH tunnel to project DIR stack, and PORT port. If DIR is remote, then attempt to open an SSH tunnel to port. If the ssh executable is not found on the stack, then fall back to specifying a direct conneciton." ;; this abuses the -v option for ssh to get output when the port ;; forwarding is set up, which is used to synchronise on, so that ;; the port forwarding is up when we try to connect. (if (file-remote-p dir) (let ((ssh (executable-find "ssh"))) (if ssh ;; run cmd in a local shell (let* ((cmd (nrepl--ssh-tunnel-command ssh dir port)) (on-connection-buffer-name (nrepl-on-connection-buffer-name)) (proc (start-process-shell-command "nrepl-on-connection" on-connection-buffer-name cmd)) (on-connection-buffer (get-buffer on-connection-buffer-name))) (with-current-buffer on-connection-buffer-name (setq-local nrepl-wait-for-port t)) (set-process-filter proc (nrepl--ssh-tunnel-filter port)) (while (and (buffer-local-value 'nrepl-wait-for-port on-connection-buffer) (process-live-p proc)) (accept-process-output nil 0.005)) (unless (process-live-p proc) (message "SSH port forwarding failed")) (list :hostname "localhost" :port port :proc-buffer-name on-connection-buffer-name)) (nrepl--default-endpoint dir port))) (list :hostname "localhost" :port port :proc-buffer-name nil))) (defun nrepl--default-endpoint (dir port) "The endpoint for a repl in project DIR on PORT. Return a plist with :hostname, :port and :proc keys." (list :hostname (if (file-remote-p dir) tramp-current-host "localhost") :port port :proc-buffer-name nil)) (defun nrepl--ssh-tunnel-command (ssh dir port) "Command string to open SSH tunnel to the host associated with DIR's PORT." (with-parsed-tramp-file-name dir nil (format-spec "%s -v -N -L %p:localhost:%p %u'%h'" `((?s . ,ssh) (?p . ,port) (?h . ,host) (?u . ,(if user (format "-l '%s' " user) "")))))) (defun nrepl--ssh-tunnel-filter (port) "Return a filter function for waiting on PORT to appear in output." (let ((port-string (format "LOCALHOST:%s" port))) (lambda (proc string) (when (buffer-live-p (process-buffer proc)) (with-current-buffer (process-buffer proc) (let ((moving (= (point) (process-mark proc)))) (save-excursion (goto-char (process-mark proc)) (insert string) (set-marker (process-mark proc) (point))) (if moving (goto-char (process-mark proc)))))) (when (string-match port-string string) (with-current-buffer (process-buffer proc) (setq nrepl-wait-for-port nil)))))) ;;; Utilities ;; message logging (defconst nrepl-message-buffer-name "*nrepl-messages*" "Buffer for nREPL message logging.") (defcustom nrepl-log-messages nil "If non-nil, log protocol messages to the `nrepl-message-buffer-name' buffer." :type 'boolean :group 'nrepl) (defconst nrepl-message-buffer-max-size 1000000 "Maximum size for the nREPL message buffer. Defaults to 1000000 characters, which should be an insignificant memory burden, while providing reasonable history.") (defconst nrepl-message-buffer-reduce-denominator 4 "Divisor by which to reduce message buffer size. When the maximum size for the nREPL message buffer is exceed, the size of the buffer is reduced by one over this value. Defaults to 4, so that 1/4 of the buffer is removed, which should ensure the buffer's maximum is reasonably utilised, while limiting the number of buffer shrinking operations.") (defun nrepl-log-message (msg) "Log the given MSG to the buffer given by `nrepl-message-buffer-name'." (when nrepl-log-messages (with-current-buffer (nrepl-messages-buffer) (when (> (buffer-size) nrepl-message-buffer-max-size) (goto-char (/ (buffer-size) nrepl-message-buffer-reduce-denominator)) (re-search-forward "^(" nil t) (delete-region (point-min) (- (point) 1))) (goto-char (point-max)) (nrepl--pp msg (current-buffer))))) (defun nrepl--pp (object &optional stream) "Pretty print nREPL objects." (let ((stream (or stream standard-output))) (if (not (nrepl-dict-p object)) (pp object stream) (princ "(dict\n" stream) (cl-loop for l on (cdr object) by #'cddr do (princ (format " %s\t%s%s" (car l) (pp-to-string (cadr l)) (if (cddr l) "\n" "")) stream)) (princ ")\n" stream)) (if (stringp object) (princ "\n" stream)))) (defun nrepl-messages-buffer () "Return or create the buffer given by `nrepl-message-buffer-name'. The default buffer name is *nrepl-messages*." (or (get-buffer nrepl-message-buffer-name) (let ((buffer (get-buffer-create nrepl-message-buffer-name))) (with-current-buffer buffer (buffer-disable-undo) (setq-local comment-start ";") (setq-local comment-end "")) buffer))) ;; other utility functions (defun nrepl-op-supported-p (op) "Return t iff the given operation OP is supported by nREPL server." (with-current-buffer (nrepl-current-connection-buffer) (and nrepl-ops (nrepl-dict-get nrepl-ops op)))) (defun nrepl-current-dir () "Return the directory of the current buffer." (let ((file-name (buffer-file-name (current-buffer)))) (or (when file-name (file-name-directory file-name)) list-buffers-directory))) (defun nrepl-project-directory-for (dir-name) "Return the project directory for the specified DIR-NAME." (when dir-name (locate-dominating-file dir-name "project.clj"))) (defun nrepl-check-for-repl-buffer (endpoint project-directory) "Check whether a matching connection buffer already exists. Looks for buffers where `nrepl-endpoint' matches ENDPOINT, or `nrepl-project-dir' matches PROJECT-DIRECTORY. If so ask the user for confirmation." (if (cl-find-if (lambda (buffer) (let ((buffer (get-buffer buffer))) (or (and endpoint (equal endpoint (buffer-local-value 'nrepl-endpoint buffer))) (and project-directory (equal project-directory (buffer-local-value 'nrepl-project-dir buffer)))))) (nrepl-connection-buffers)) (y-or-n-p "An nREPL connection buffer already exists. Do you really want to create a new one? ") t)) (defun nrepl-close (connection-buffer) "Close the nrepl connection for CONNECTION-BUFFER." (interactive (list (nrepl-current-connection-buffer))) (nrepl--close-connection-buffer connection-buffer) (run-hooks 'nrepl-disconnected-hook) (nrepl--connections-refresh)) ;;; Connection Buffer Management (defvar nrepl-connection-dispatch nil "Bound to the connection a message was received on. This is bound for the duration of the handling of that message") (defvar nrepl-connection-list nil "A list of connections.") (defun nrepl-current-host () "Retrieve the current host." (if (and (stringp buffer-file-name) (file-remote-p buffer-file-name)) tramp-current-host nrepl-host)) (defun nrepl-create-connection-buffer (&optional project-dir host port) "Create an nREPL connection buffer. PROJECT-DIR, HOST and PORT are as in `nrepl-make-buffer-name'." (let ((buffer (generate-new-buffer (nrepl-connection-buffer-name project-dir host port)))) (with-current-buffer buffer (buffer-disable-undo) (setq-local kill-buffer-query-functions nil)) buffer)) (defun nrepl-current-connection-buffer () "The connection to use for nREPL interaction." (or nrepl-connection-dispatch nrepl-connection-buffer (car (nrepl-connection-buffers)) (error "No nREPL connection buffer"))) (defun nrepl-connection-buffers () "Return the connection list. Purge the dead buffers from the `nrepl-connection-list' beforehand." (setq nrepl-connection-list (-remove (lambda (buffer) (not (buffer-live-p (get-buffer buffer)))) nrepl-connection-list))) ;; VS[06-08-2014]: FIXME: Bad user api; don't burden users with management of ;; the connection list, same holds for `cider-rotate-connection'. (defun nrepl-make-connection-default (connection-buffer) "Make the nREPL CONNECTION-BUFFER the default connection. Moves CONNECITON-BUFFER to the front of `nrepl-connection-list'." (interactive (list nrepl-connection-buffer)) (if connection-buffer ;; maintain the connection list in most recently used order (let ((buf-name (buffer-name (get-buffer connection-buffer)))) (setq nrepl-connection-list (cons buf-name (delq buf-name nrepl-connection-list))) (nrepl--connections-refresh)) (message "Not in an nREPL REPL buffer."))) (defun nrepl--close-connection-buffer (connection-buffer) "Closes CONNECTION-BUFFER, removing it from `nrepl-connection-list'. Also closes associated REPL and server buffers." (let ((nrepl-connection-dispatch connection-buffer)) (let ((buffer (get-buffer connection-buffer))) (setq nrepl-connection-list (delq (buffer-name buffer) nrepl-connection-list)) (when (buffer-live-p buffer) (dolist (buf-name `(,(buffer-local-value 'nrepl-server-buffer buffer) ,(buffer-local-value 'nrepl-on-connection-buffer buffer) ,buffer)) (when buf-name (cider--close-buffer buf-name))))))) ;;; Connection Browser ;; VS[06-08-2014]: FIXME: Naming conventions are pretty messy here. Some ;; interactive commands are named with "--". nrepl--project-name` is pretty ;; often used across cider, so it's not very internal. (defvar nrepl-connections-buffer-mode-map (let ((map (make-sparse-keymap))) (define-key map "d" 'nrepl-connections-make-default) (define-key map "g" 'nrepl-connection-browser) (define-key map (kbd "C-k") 'nrepl-connections-close-connection) (define-key map (kbd "RET") 'nrepl-connections-goto-connection) map)) (define-derived-mode nrepl-connections-buffer-mode cider-popup-buffer-mode "nREPL-Connections" "nREPL Connections Buffer Mode. \\{nrepl-connections-buffer-mode-map} \\{cider-popup-buffer-mode-map}" (setq-local truncate-lines t)) (defvar nrepl--connection-ewoc) (defconst nrepl--connection-browser-buffer-name "*nrepl-connections*") (defun nrepl-connection-browser () "Open a browser buffer for nREPL connections." (interactive) (let ((buffer (get-buffer nrepl--connection-browser-buffer-name))) (if buffer (progn (nrepl--connections-refresh-buffer buffer) (unless (get-buffer-window buffer) (select-window (display-buffer buffer)))) (nrepl--setup-connection-browser)))) (defun nrepl--connections-refresh () "Refresh the connections buffer, if the buffer exists. The connections buffer is determined by `nrepl--connection-browser-buffer-name'" (let ((buffer (get-buffer nrepl--connection-browser-buffer-name))) (when buffer (nrepl--connections-refresh-buffer buffer)))) (defun nrepl--connections-refresh-buffer (buffer) "Refresh the connections BUFFER." (nrepl--update-connections-display (buffer-local-value 'nrepl--connection-ewoc buffer) nrepl-connection-list)) (defun nrepl--setup-connection-browser () "Create a browser buffer for nREPL connections." (with-current-buffer (get-buffer-create nrepl--connection-browser-buffer-name) (let ((ewoc (ewoc-create 'nrepl--connection-pp " Host Port Project\n"))) (setq-local nrepl--connection-ewoc ewoc) (nrepl--update-connections-display ewoc nrepl-connection-list) (setq buffer-read-only t) (nrepl-connections-buffer-mode) (display-buffer (current-buffer))))) (defun nrepl--connection-pp (connection) "Print an nREPL CONNECTION to the current buffer." (let* ((buffer-read-only nil) (buffer (get-buffer connection)) (endpoint (buffer-local-value 'nrepl-endpoint buffer))) (insert (format "%s %-16s %5s %s" (if (equal connection (car nrepl-connection-list)) "*" " ") (car endpoint) (prin1-to-string (cadr endpoint)) (or (nrepl--project-name (buffer-local-value 'nrepl-project-dir buffer)) ""))))) (defun nrepl--project-name (stack) "Extracts a project name from STACK, possibly nil. The project name is the final component of STACK if not nil." (when stack (file-name-nondirectory (directory-file-name stack)))) (defun nrepl--update-connections-display (ewoc connections) "Update the connections EWOC to show CONNECTIONS." (ewoc-filter ewoc (lambda (n) (member n connections))) (let ((existing)) (ewoc-map (lambda (n) (setq existing (cons n existing))) ewoc) (let ((added (-difference connections existing))) (mapc (apply-partially 'ewoc-enter-last ewoc) added) (save-excursion (ewoc-refresh ewoc))))) (defun nrepl--ewoc-apply-at-point (f) "Apply function F to the ewoc node at point. F is a function of two arguments, the ewoc and the data at point." (let* ((ewoc nrepl--connection-ewoc) (node (and ewoc (ewoc-locate ewoc)))) (when node (funcall f ewoc (ewoc-data node))))) (defun nrepl-connections-make-default () "Make default the connection at point in the connection browser." (interactive) (save-excursion (nrepl--ewoc-apply-at-point #'nrepl--connections-make-default))) (defun nrepl--connections-make-default (ewoc data) "Make the connection in EWOC specified by DATA default. Refreshes EWOC." (interactive) (nrepl-make-connection-default data) (ewoc-refresh ewoc)) (defun nrepl-connections-close-connection () "Close connection at point in the connection browser." (interactive) (nrepl--ewoc-apply-at-point #'nrepl--connections-close-connection)) (defun nrepl--connections-close-connection (ewoc data) "Close the connection in EWOC specified by DATA." (nrepl-close (get-buffer data)) (nrepl--update-connections-display ewoc nrepl-connection-list)) (defun nrepl-connections-goto-connection () "Goto connection at point in the connection browser." (interactive) (nrepl--ewoc-apply-at-point #'nrepl--connections-goto-connection)) (defun nrepl--connections-goto-connection (_ewoc data) "Goto the REPL for the connection in _EWOC specified by DATA." (let ((buffer (buffer-local-value 'nrepl-repl-buffer (get-buffer data)))) (when buffer (select-window (display-buffer buffer))))) (define-obsolete-function-alias 'nrepl-send-request-sync 'nrepl-send-sync-request "0.8.0") (define-obsolete-function-alias 'nrepl-send-string 'nrepl-request:eval "0.8.0") (define-obsolete-function-alias 'nrepl-send-string-sync 'nrepl-sync-request:eval "0.8.0") (define-obsolete-variable-alias 'nrepl-log-events 'nrepl-log-messages "0.7.0") (provide 'nrepl-client) ;;; nrepl-client.el ends here