--- /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)
--- 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")
--- 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):
--- 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))))))))
--- 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
--- 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)
--- 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."
--- 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
--- 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]" ")")))
-