# HG changeset patch # User Steve Losh # Date 1460234554 0 # Node ID 743c0a981785de1bd3409b0803f694fab3adad06 # Parent d74fc3dab8fa74dc23b5ee3229b46da251c395d0 Oh boy, here we go... Finally getting back to poking at this. Apparently my Common Lisp has gotten better in the past six months because good lord this code looks bad now. Anyway, a few changes: * Make it run on CCL by working around a usocket bug. * Remove the workaround hacks. It's never gonna work with Fireplace anyway. * Make the socket stream once instead of on every read/write so the GC doesn't hate us. diff -r d74fc3dab8fa -r 743c0a981785 .lispwords --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/.lispwords Sat Apr 09 20:42:34 2016 +0000 @@ -0,0 +1,8 @@ +(1 with-when) +(1 run-in-thread) + +; bordeaux threads +(1 with-lock-held) + +; fset +(1 with) diff -r d74fc3dab8fa -r 743c0a981785 nrepl.asd --- a/nrepl.asd Wed Dec 09 17:47:41 2015 +0000 +++ b/nrepl.asd Sat Apr 09 20:42:34 2016 +0000 @@ -6,23 +6,22 @@ :version "0.0.1" :license "EPL" :depends-on (#:bencode - #:usocket - #:flexi-streams - #:bordeaux-threads - #:uuid - #:fset - #:cl-ppcre - #+sbcl :sb-introspect) + #:usocket + #:flexi-streams + #:bordeaux-threads + #:uuid + #:fset + #:cl-ppcre + #:split-sequence + #+sbcl :sb-introspect) :components ((:file "package") (:module "src" :depends-on ("package") - :components ((:file "utils" :depends-on ()) + :components ((:file "utils" :depends-on ()) (:file "sockets" :depends-on ("utils")) - (:file "workarounds" :depends-on ("utils")) (:file "server" :depends-on ("utils" "sockets" - "workarounds" "middleware")) (:module "middleware" :depends-on ("utils") diff -r d74fc3dab8fa -r 743c0a981785 sender.py --- a/sender.py Wed Dec 09 17:47:41 2015 +0000 +++ b/sender.py Sat Apr 09 20:42:34 2016 +0000 @@ -10,7 +10,7 @@ from pprint import pformat -ADDRESS = '127.0.0.1' +ADDRESS = 'localhost' PORT = int(sys.argv[1]) def build_eval(data): diff -r d74fc3dab8fa -r 743c0a981785 src/middleware/documentation.lisp --- a/src/middleware/documentation.lisp Wed Dec 09 17:47:41 2015 +0000 +++ b/src/middleware/documentation.lisp Sat Apr 09 20:42:34 2016 +0000 @@ -1,10 +1,40 @@ (in-package #:nrepl) +(defun lambda-list-to-string (l) + "Return a single-line string of the lambda list." + (if (listp l) + (format nil "(~{~A~^ ~})" (mapcar #'lambda-list-to-string l)) + (princ-to-string l))) + (defun find-lambda-list (s) - (when (fboundp s) - (sb-introspect:function-lambda-list s))) + "Return the lambda list for the given symbol. + + Will return `nil` if none is found. A second value is returned to indicate + whether it was found. + + " + (if (fboundp s) + (values + #+sbcl (sb-introspect:function-lambda-list s) + #+ccl (ccl:arglist s) + t) + (values nil nil))) + (defun find-symbol-harder (name) + "Return the symbol object with the given `name`. + + This should work with: + + FOO (assumes the current package) + P:FOO (looks in package P) + + TODO: add support for: + + P::FOO + :KEYWORD + + " (flet ((split-string (s delim) (let ((idx (position delim s))) (if idx @@ -17,15 +47,28 @@ *package*))))) (define-middleware wrap-documentation "documentation" message - (let* ((s (find-symbol-harder (fset:lookup message "symbol")))) + (let ((s (find-symbol-harder (fset:lookup message "symbol")))) (respond message (with-when - (make-map "status" '("done")) + (make-map "status" '("done")) "type-docstring" (documentation s 'type) "structure-docstring" (documentation s 'structure) "variable-docstring" (documentation s 'variable) "setf-docstring" (documentation s 'setf) "function-docstring" (documentation s 'function) - "function-arglist" (when-let ((arglist (find-lambda-list s))) - (prin1-to-string arglist)))))) + "function-arglist" + (multiple-value-bind (arglist foundp) + (find-lambda-list s) + (when foundp + (princ-to-string (cons s arglist)))))))) +(define-middleware wrap-arglist "arglist" message + (let ((s (find-symbol-harder (fset:lookup message "symbol")))) + (respond message + (with-when + (make-map "status" '("done")) + "function-arglist" + (multiple-value-bind (arglist foundp) + (find-lambda-list s) + (when foundp + (lambda-list-to-string (cons s arglist)))))))) diff -r d74fc3dab8fa -r 743c0a981785 src/middleware/eval.lisp --- a/src/middleware/eval.lisp Wed Dec 09 17:47:41 2015 +0000 +++ b/src/middleware/eval.lisp Sat Apr 09 20:42:34 2016 +0000 @@ -35,6 +35,35 @@ :text "Malformed input!" :orig e)))) +(defun clean-backtrace (backtrace) + (format nil "~{~A~^~%~}" + (loop :for line :in (split-sequence:split-sequence #\newline backtrace) + :until (ppcre:scan "NREPL::NREPL-EVALUATE-FORM" line) + :collect line))) + +(defun nrepl-evaluate-form (form) + (declare (optimize (debug 3))) + ;im so sorry you have to see this + (prin1-to-string + (handler-bind + ((error + (lambda (err) + ; if we hit an error, print the backtrace to the stream before + ; reraising. if we wait til later to print it, it'll be too late. + (error 'evaluation-error + :text "Error during evaluation!" + :orig err + :data (list + "form" (prin1-to-string form) + "backtrace" (clean-backtrace + #+sbcl (with-output-to-string (s) + (sb-debug:print-backtrace + :stream s + :print-frame-source t + :from :interrupted-frame)) + #-sbcl "dunno")))))) + (eval form)))) + (define-middleware wrap-eval "eval" message (let* ((code (fset:lookup message "code")) (captured-out (flex:make-in-memory-output-stream)) @@ -44,17 +73,10 @@ (*error-output* (flex:make-flexi-stream captured-err :external-format :utf-8))) (flet ((eval-form (form) - (handler-case - (let ((result (prin1-to-string (eval form)))) - (respond message - (make-map "form" (prin1-to-string form) - "value" result))) - (error (e) - (error 'evaluation-error - :text "Traceback during evaluation!" - :orig e - :data (list - "form" (prin1-to-string form)))))) + (let ((result (nrepl-evaluate-form form))) + (respond message + (make-map "form" (prin1-to-string form) + "value" result)))) (error-respond (e) (respond message (apply #'make-map diff -r d74fc3dab8fa -r 743c0a981785 src/middleware/load-file.lisp --- a/src/middleware/load-file.lisp Wed Dec 09 17:47:41 2015 +0000 +++ b/src/middleware/load-file.lisp Sat Apr 09 20:42:34 2016 +0000 @@ -1,6 +1,5 @@ (in-package #:nrepl) - (define-middleware wrap-load-file "load-file" message (let ((path (fset:lookup message "path"))) (load path) diff -r d74fc3dab8fa -r 743c0a981785 src/server.lisp --- a/src/server.lisp Wed Dec 09 17:47:41 2015 +0000 +++ b/src/server.lisp Sat Apr 09 20:42:34 2016 +0000 @@ -1,5 +1,9 @@ (in-package #:nrepl) +;;;; Config +(defvar *verbose-debug-output* nil) +(defvar *unthreaded* nil) + ;;;; Plumbing (defun handle-base (message) @@ -17,17 +21,13 @@ #'wrap-session-ls #'wrap-session-clone #'wrap-session-close - ; just kill me please - #'workaround-fireplace-classpath - #'workaround-fireplace-pathsep - #'workaround-fireplace-star - #'workaround-fireplace-fakepathsep - #'workaround-fireplace-macroexpand-all #'wrap-describe #'wrap-load-file #'wrap-macroexpand #'wrap-eval - #'wrap-documentation)) + #'wrap-documentation + #'wrap-arglist + )) (defun build-handler (base middleware) "Collapse the stack of middleware into a single handler function." @@ -38,19 +38,22 @@ (defun handle (message) "Handle the given NREPL message." - (l "Handling message: vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv~%~A~%^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^~%" message) + (when *verbose-debug-output* + (l "Handling message: vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv~%") + (l "~A~%" message) + (l "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^~%")) (funcall (build-handler #'handle-base (middleware)) message)) -(defun handle-message (socket lock) - "Read a single message from the socket and handle it." - (let ((message (fset:with (read-object socket) - "transport" (curry #'write-object socket lock)))) +(defun handle-message (socket-stream lock) + "Read and handle a single message from the socket." + (let ((message (fset:with (read-object socket-stream) + "transport" (curry #'write-object socket-stream lock)))) (handle message))) -(defun handler (socket lock) - "Read a series of messages from the socket, handling each." +(defun handler (socket-stream lock) + "Read a series of messages from the socket-stream, handling each." (p "Client connected...") - (handler-case (loop (handle-message socket lock)) + (handler-case (loop (handle-message socket-stream lock)) (end-of-file () nil)) (p "Client disconnected...")) @@ -58,31 +61,50 @@ ;;;; Server (defvar *server-thread* nil) +(defmacro run-in-thread (thread-name &rest body) + "Run `body` in a thread called `name` (usually). Return the thread. + + If `nrepl::*unthreaded*` is true, the body will be executed immediately in the + current thread and `nil` will be returned instead. Useful for debugging. + + " + `(let ((thunk (lambda () ,@body))) + (if *unthreaded* + (progn (funcall thunk) nil) + (bt:make-thread thunk :name ,thread-name)))) + + (defun accept-connections (server-socket) "Accept connections to the server and spawn threads to handle each." + (format t "Accepting connections...~%") (loop - (let ((client-socket (usocket:socket-accept - server-socket - :element-type '(unsigned-byte 8))) - (write-lock (bt:make-lock "NREPL client writing lock"))) - (bt:make-thread - (lambda () - (unwind-protect (handler client-socket write-lock) - (usocket:socket-close client-socket))) - :name "NREPL Connection Handler")))) + (let* ((client-socket (usocket:socket-accept + server-socket + :element-type '(unsigned-byte 8))) + (socket-stream (flex:make-flexi-stream + (usocket:socket-stream client-socket) + :external-format :utf-8)) + (write-lock (bt:make-lock "NREPL client writing lock"))) + (run-in-thread "NREPL Connection Handler" + (unwind-protect + (handler socket-stream write-lock) + (usocket:socket-close client-socket)))))) -(defun start-server (&optional (address "localhost") (port 8675)) +(defun start-server (&optional (address "127.0.0.1") (port 8675)) "Fire up a server thread that will listen for connections." (format t "Starting server...~%") - (let ((socket (usocket:socket-listen address port :reuse-address t))) + (let ((socket (usocket:socket-listen + address port + :reuse-address t + ;; have to specify element-type here too because usocket+CCL + ;; fucks it up if you only specify it in socket-accept + :element-type '(unsigned-byte 8)))) (setf *server-thread* - (bt:make-thread - (lambda () - (unwind-protect + (run-in-thread (format nil "NREPL Server (~a/~a)" address port) + (unwind-protect (accept-connections socket) - (format t "Closing server socket...~%") - (usocket:socket-close socket))) - :name (format nil "NREPL Server (~a/~a)" address port))))) + (format t "Closing server socket...~%") + (usocket:socket-close socket)))))) (defun stop-server () "Kill the server thread, if it exists." diff -r d74fc3dab8fa -r 743c0a981785 src/sockets.lisp --- a/src/sockets.lisp Wed Dec 09 17:47:41 2015 +0000 +++ b/src/sockets.lisp Sat Apr 09 20:42:34 2016 +0000 @@ -1,25 +1,15 @@ (in-package #:nrepl) -(defun get-stream (sock) - "Make a flexi stream of the kind bencode wants from the socket." - (flex:make-flexi-stream - (usocket:socket-stream sock) - :external-format :utf-8)) - - -(defun write-object (socket lock o) - "Bencode and write a map M to SOCKET while holding LOCK." +;;;; In/out +(defun write-object (socket-stream lock map) + "Bencode and write `map` to `socket-stream` while holding `lock`." (bt:with-lock-held (lock) - (bencode:encode o (get-stream socket)) - (force-output (get-stream socket)))) + (bencode:encode map socket-stream) + (force-output socket-stream))) -(defun read-object (socket) - "Read a map (and bdecode it) from *socket*." - (fset:convert 'fset:map - ; fireplace's bencoding is fucked. - ; just ignore it its fine - (handler-bind ((error #'continue)) - (bencode:decode (get-stream socket))))) +(defun read-object (socket-stream) + "Read and bdecode a map from `socket-stream`." + (fset:convert 'fset:map (bencode:decode socket-stream))) ;;; Patch in support for writing fset data types to bencode diff -r d74fc3dab8fa -r 743c0a981785 src/workarounds.lisp --- a/src/workarounds.lisp Wed Dec 09 17:47:41 2015 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,77 +0,0 @@ -(in-package #:nrepl) - -; WELCOME TO THE JUNGLE -; WE'VE GOT HACKS AND STRINGS -; YOU CAN GET ANYTHING YOU WANT -; BUT IT BETTER BE HACKS OR STRINGS - -(defun workaround-matches (l code) - (equal (apply #'concatenate 'string l) - code)) - -(defmacro handle-workaround (message fallback op check &rest body) - `(if (and (equal ,op (fset:lookup ,message "op")) - (,@check (fset:lookup ,message "code"))) - (progn - ,@body - (respond ,message (make-map "status" '("done")))) - (funcall ,fallback ,message))) - -(defmacro define-workaround (name op message-binding &rest body) - (let ((fallback (gensym))) - `(defun ,name (,fallback) - (lambda (,message-binding) - (handle-workaround - ,message-binding ,fallback ,op - ,@body))))) - - -(define-workaround workaround-fireplace-classpath "eval" message - (workaround-matches - '("(do (println \"success\") " - "(symbol (str (System/getProperty \"path.separator\") " - "(System/getProperty \"java.class.path\"))))")) - (respond message (make-map "value" ":"))) - -(define-workaround workaround-fireplace-pathsep "eval" message - (workaround-matches - '("[(System/getProperty \"path.separator\") " - "(System/getProperty \"java.class.path\")]")) - (respond message (make-map "value" "[\"/\" \":\"]"))) - -(define-workaround workaround-fireplace-star "eval" message - ((lambda (code) - (member code '("(*1 1)" "(*2 2)" "(*3 3)") :test #'equal))) - (respond message (make-map "value" "Not yet implemented, sorry :("))) - -(define-workaround workaround-fireplace-fakepathsep "eval" message - ; lol what in the fuck even is this for? - (workaround-matches - '("[(System/getProperty \"path.separator\") " - "(System/getProperty \"fake.class.path\")]")) - (respond message (make-map "value" "[\"/\" \"None\"]"))) - -(define-workaround workaround-fireplace-macroexpand-all "eval" message - ; this should really do a macroexpand-all but this'll have to do for now - (starts-with "(clojure.walk/macroexpand-all (quote") - ; TODO: Fix the extra done status message here - (funcall h (with-map message "code" - (lambda (s) - (ppcre:regex-replace - "clojure.walk/macroexpand-all" - s - "macroexpand"))))) - -; TODO: (def-workaround (+ "[(symbol (str \"\\n\\b\" (apply str (interleave " -; "(repeat \"\\n\") (map str (.getStackTrace *e)))) " -; "\"\\n\\b\\n\")) *3 *2 *1]") -; [session msg] -; (let [items []] -; (with [session.lock] -; (for [i (traceback.extract-tb session.last-traceback)] -; (.append items (.format "{}({}:{})" -; (get i 2) -; (first i) -; (second i))))) -; (+ "(quote " "[\n\b\n" (.join "\n" items) "\n\b\n nil nil nil]" ")"))) -