--- a/.hgignore Sun Aug 21 12:21:26 2016 +0000
+++ b/.hgignore Sun Aug 21 12:58:15 2016 +0000
@@ -5,4 +5,4 @@
*.swo
*.un~
tags
-src/scratch.lisp
+scratch.lisp
--- a/nrepl.asd Sun Aug 21 12:21:26 2016 +0000
+++ b/nrepl.asd Sun Aug 21 12:58:15 2016 +0000
@@ -24,6 +24,7 @@
(:module "src"
:components ((:file "utils")
(:file "sockets")
+ (:file "evaluation")
(:module "middleware"
:components ((:file "core")
(:file "describe")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/evaluation.lisp Sun Aug 21 12:58:15 2016 +0000
@@ -0,0 +1,135 @@
+(in-package #:nrepl)
+
+(define-condition evaluation-error (error)
+ ((text :initarg :text :reader text)
+ (orig :initarg :orig :reader orig)
+ (data :initarg :data :reader data :initform ())))
+
+(defclass evaluator ()
+ ((standard-input :initarg :in :reader in)
+ (standard-output :initarg :out :reader out)
+ (standard-error :initarg :err :reader err)))
+
+
+(defun read-data (stream)
+ (flex:octets-to-string
+ (flex:get-output-stream-sequence stream)
+ :external-format :utf-8))
+
+(defun shuttle-stream (stream stream-name message)
+ "Read data from `stream` and shuttle it back to the client.
+
+ Chunks of data will be read from `stream` until it's finished and closed.
+
+ For each hunk of data read, a response will be sent back to the client using
+ the transport defined in `message`, looking something like:
+
+ {\"status\" \"ok\"
+ \"stdout\" \"...data...\"}
+
+ `stream-name` should be the name of the stream being shuttled, like
+ \"stderr\", and will be used as the key in the response.
+
+ "
+ (loop
+ :for data = (read-data stream)
+ :until (and (not (open-stream-p stream))
+ (equal data ""))
+ :do (progn
+ (when (not (string= data ""))
+ (respond message (make-map "status" '("ok")
+ stream-name data)))
+ (sleep 0.1))))
+
+
+(defun get-forms (code)
+ "Get all lisp forms from `code`.
+
+ If `code` is a string, the forms will be read out of it, and an
+ `evaluation-error` signaled if the input is mangled.
+
+ If `code` is anything else it will just be returned as-is.
+
+ "
+ (if (stringp code)
+ (handler-case
+ (read-all-from-string code)
+ (error (e)
+ (error 'evaluation-error
+ :text "Malformed input!"
+ :orig e)))
+ code))
+
+(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))))
+
+
+(defun evaluate-forms (message forms &optional in-package)
+ "Evaluate each form in `forms` and shuttle back the responses.
+
+ `forms` can be a string, in which case the forms will be read out of it, or
+ a ready-to-go list of actual forms.
+
+ `in-package` can be a package designator, or `nil` to just use `*package*`.
+
+ "
+ (let* ((captured-out (flex:make-in-memory-output-stream))
+ (captured-err (flex:make-in-memory-output-stream))
+ (*standard-output*
+ (flex:make-flexi-stream captured-out :external-format :utf-8))
+ (*error-output*
+ (flex:make-flexi-stream captured-err :external-format :utf-8)))
+ (flet ((eval-form (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
+ "status" '("error")
+ "error" (text e)
+ "original" (format nil "~S" (orig e))
+ (data e))))
+ (make-shuttle-thread (stream desc)
+ (bt:make-thread
+ (lambda () (shuttle-stream stream desc message))
+ :name (format nil "NREPL ~A writer" desc))))
+ (unwind-protect
+ (progn
+ (make-shuttle-thread captured-out "stdout")
+ (make-shuttle-thread captured-err "stderr")
+ (handler-case
+ (progn
+ (let ((*package* (parse-in-package in-package)))
+ (mapc #'eval-form (get-forms forms)))
+ (respond message (make-map "status" '("done"))))
+ (evaluation-error (e) (error-respond e))))
+ (close captured-out)
+ (close captured-err)))))
--- a/src/middleware/documentation.lisp Sun Aug 21 12:21:26 2016 +0000
+++ b/src/middleware/documentation.lisp Sun Aug 21 12:58:15 2016 +0000
@@ -1,22 +1,22 @@
(in-package #:nrepl)
-(defun lambda-list-to-string (l)
+(defun lambda-list-to-string (lambda-list)
"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)))
+ (if (listp lambda-list)
+ (format nil "(~{~A~^ ~})" (mapcar #'lambda-list-to-string lambda-list))
+ (princ-to-string lambda-list)))
-(defun find-lambda-list (s)
+(defun find-lambda-list (symbol)
"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)
+ (if (fboundp symbol)
(values
- #+sbcl (sb-introspect:function-lambda-list s)
- #+ccl (ccl:arglist s)
+ #+sbcl (sb-introspect:function-lambda-list symbol)
+ #+ccl (ccl:arglist symbol)
t)
(values nil nil)))
@@ -76,30 +76,26 @@
(define-middleware wrap-documentation "documentation" message
- (let ((s (find-symbol-harder (fset:lookup message "symbol")
- (fset:lookup message "in-package"))))
+ (let ((symbol (find-symbol-harder (fset:lookup message "symbol")
+ (fset:lookup message "in-package"))))
(respond message
(with-when
(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)
+ "type-docstring" (documentation symbol 'type)
+ "structure-docstring" (documentation symbol 'structure)
+ "variable-docstring" (documentation symbol 'variable)
+ "setf-docstring" (documentation symbol 'setf)
+ "function-docstring" (documentation symbol 'function)
"function-arglist"
- (multiple-value-bind (arglist foundp)
- (find-lambda-list s)
- (when foundp
- (princ-to-string (cons s arglist))))))))
+ (when-found arglist (find-lambda-list symbol)
+ (princ-to-string (cons symbol arglist)))))))
(define-middleware wrap-arglist "arglist" message
- (let ((s (find-symbol-harder (fset:lookup message "symbol")
- (fset:lookup message "in-package"))))
+ (let ((symbol (find-symbol-harder (fset:lookup message "symbol")
+ (fset:lookup message "in-package"))))
(respond message
(with-when
- (make-map "status" '("done"))
+ (make-map "status" '("done"))
"function-arglist"
- (multiple-value-bind (arglist foundp)
- (find-lambda-list s)
- (when foundp
- (lambda-list-to-string (cons s arglist))))))))
+ (when-found arglist (find-lambda-list symbol)
+ (lambda-list-to-string (cons symbol arglist)))))))
--- a/src/middleware/eval.lisp Sun Aug 21 12:21:26 2016 +0000
+++ b/src/middleware/eval.lisp Sun Aug 21 12:58:15 2016 +0000
@@ -1,122 +1,5 @@
(in-package #:nrepl)
-(define-condition evaluation-error (error)
- ((text :initarg :text :reader text)
- (orig :initarg :orig :reader orig)
- (data :initarg :data :reader data :initform ())))
-
-(defclass evaluator ()
- ((standard-input :initarg :in :reader in)
- (standard-output :initarg :out :reader out)
- (standard-error :initarg :err :reader err)))
-
-(defun shuttle-stream (from-stream stream-name message)
- (do ((data "" (flex:octets-to-string
- (flex:get-output-stream-sequence from-stream)
- :external-format :utf-8)))
- ((and (not (open-stream-p from-stream))
- (equal data ""))
- nil)
- (when (not (equal data ""))
- (respond message (make-map "status" '("ok")
- stream-name data)))
- (sleep 0.1)))
-
-(defun get-forms (code)
- "Get all lisp forms from `code`.
-
- If `code` is a string, the forms will be read out of it, and an
- `evaluation-error` signaled if the input is mangled.
-
- If `code` is anything else it will just be returned as-is.
-
- "
- (if (stringp code)
- (handler-case
- (read-all-from-string code)
- (error (e)
- (error 'evaluation-error
- :text "Malformed input!"
- :orig e)))
- code))
-
-(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))))
-
-
-(defun evaluate-forms (message forms &optional in-package)
- "Evaluate each form in `forms` and shuttle back the responses.
-
- `forms` can be a string, in which case the forms will be read out of it, or
- a ready-to-go list of actual forms.
-
- `in-package` can be a package designator, or `nil` to just use `*package*`.
-
- Other middlewares (e.g. `load-file`) can use this function to evaluate things
- and send the results back to the user.
-
- "
- (let* ((captured-out (flex:make-in-memory-output-stream))
- (captured-err (flex:make-in-memory-output-stream))
- (*standard-output*
- (flex:make-flexi-stream captured-out :external-format :utf-8))
- (*error-output*
- (flex:make-flexi-stream captured-err :external-format :utf-8)))
- (flet ((eval-form (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
- "status" '("error")
- "error" (text e)
- "original" (format nil "~A" (orig e))
- (data e))))
- (make-shuttle-thread (stream desc)
- (bt:make-thread
- (lambda () (shuttle-stream stream desc message))
- :name (format nil "NREPL ~A writer" desc))))
- (unwind-protect
- (progn
- (make-shuttle-thread captured-out "stdout")
- (make-shuttle-thread captured-err "stderr")
- (handler-case
- (progn
- (let ((*package* (parse-in-package in-package)))
- (mapc #'eval-form (get-forms forms)))
- (respond message (make-map "status" '("done"))))
- (evaluation-error (e) (error-respond e))))
- (close captured-out)
- (close captured-err)))))
-
(define-middleware wrap-eval "eval" message
(evaluate-forms message
(fset:lookup message "code")
--- a/src/middleware/session.lisp Sun Aug 21 12:21:26 2016 +0000
+++ b/src/middleware/session.lisp Sun Aug 21 12:58:15 2016 +0000
@@ -4,11 +4,11 @@
(defvar *session* nil)
-(defun clear-sessions! ()
- (setf *sessions* (make-hash-table :test #'equal)))
+(defun make-session ()
+ (fset:empty-map))
-(defun create-session ()
- (fset:empty-map))
+(defun clear-sessions! ()
+ (clrhash *sessions*))
(defun register-session! (id session)
(setf (gethash id *sessions*) session))
@@ -42,7 +42,7 @@
(let* ((session-id (fset:lookup message "session"))
(session (if session-id
(get-session session-id)
- (create-session)))
+ (make-session)))
(session-id (or session-id (random-uuid)))
(*session* session))
(funcall handler (fset:with message "session" session-id)))))
--- a/src/sockets.lisp Sun Aug 21 12:21:26 2016 +0000
+++ b/src/sockets.lisp Sun Aug 21 12:58:15 2016 +0000
@@ -12,7 +12,7 @@
(fset:convert 'fset:map (bencode:decode socket-stream)))
-;;; Patch in support for writing fset data types to bencode
+;;;; FSet+Bencode
(defmethod bencode:encode ((fm fset:map) stream &key &allow-other-keys)
(bencode:encode (fset:convert 'hash-table fm) stream))
--- a/src/utils.lisp Sun Aug 21 12:21:26 2016 +0000
+++ b/src/utils.lisp Sun Aug 21 12:58:15 2016 +0000
@@ -73,3 +73,26 @@
(if (or (null in-package) (string= in-package ""))
*package*
(or (find-package (read-from-string in-package)) *package*)))
+
+
+(defmacro when-found (var lookup-expr &body body)
+ "Perform `body` with `var` to the results of `lookup-expr`, when valid.
+
+ `lookup-expr` should be an expression that returns two values, the first being
+ the result (which will be bound to `var`) and the second indicating whether
+ the lookup was successful. The standard `gethash` is an example of a function
+ that behaves like this.
+
+ Instead of:
+ (multiple-value-bind (val found) (gethash :foo hash)
+ (when found
+ body))
+
+ (when-found val (gethash :foo hash)
+ body)
+
+ "
+ (let ((found (gensym "found")))
+ `(multiple-value-bind (,var ,found) ,lookup-expr
+ (when ,found
+ ,@body))))