slynk-rpc.lisp (7449B)
1 ;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*- 2 ;;; 3 ;;; slynk-rpc.lisp -- Pass remote calls and responses between lisp systems. 4 ;;; 5 ;;; Created 2010, Terje Norderhaug <terje@in-progress.com> 6 ;;; 7 ;;; This code has been placed in the Public Domain. All warranties 8 ;;; are disclaimed. 9 ;;; 10 11 (defpackage #:slynk-rpc 12 (:use :cl) 13 (:export 14 #:read-message 15 #:read-packet 16 #:slynk-reader-error 17 #:slynk-reader-error.packet 18 #:slynk-reader-error.cause 19 #:write-message 20 #:*translating-swank-to-slynk*)) 21 22 (in-package :slynk-rpc) 23 24 25 ;;;;; Input 26 27 (define-condition slynk-reader-error (reader-error) 28 ((packet :type string :initarg :packet 29 :reader slynk-reader-error.packet) 30 (cause :type reader-error :initarg :cause 31 :reader slynk-reader-error.cause))) 32 33 (defun read-message (stream package) 34 (let ((packet (read-packet stream))) 35 (handler-case (values (read-form packet package)) 36 (reader-error (c) 37 (error 'slynk-reader-error 38 :packet packet :cause c))))) 39 40 (defun read-packet (stream) 41 (let* ((length (parse-header stream)) 42 (octets (read-chunk stream length))) 43 (handler-case (slynk-backend:utf8-to-string octets) 44 (error (c) 45 (error 'slynk-reader-error 46 :packet (asciify octets) 47 :cause c))))) 48 49 (defun asciify (packet) 50 (with-output-to-string (*standard-output*) 51 (loop for code across (etypecase packet 52 (string (map 'vector #'char-code packet)) 53 (vector packet)) 54 do (cond ((<= code #x7f) (write-char (code-char code))) 55 (t (format t "\\x~x" code)))))) 56 57 (defun parse-header (stream) 58 (parse-integer (map 'string #'code-char (read-chunk stream 6)) 59 :radix 16)) 60 61 (defun read-chunk (stream length) 62 (let* ((buffer (make-array length :element-type '(unsigned-byte 8))) 63 (count (read-sequence buffer stream))) 64 (cond ((= count length) 65 buffer) 66 ((zerop count) 67 (error 'end-of-file :stream stream)) 68 (t 69 (error "Short read: length=~D count=~D" length count))))) 70 71 (defparameter *translating-swank-to-slynk* t 72 "Set to true to ensure SWANK*::SYMBOL is interned SLYNK*::SYMBOL. 73 Set by default to T to ensure that bootstrapping can occur from 74 clients sending strings like this on the wire. 75 76 (:EMACS-REX (SWANK:CONNECTION-INFO) NIL T 1) 77 78 *before* the slynk-retro.lisp contrib kicks in and renames SLYNK* 79 packages to SWANK*. After this happens, this variable is set to NIL, 80 since the translation is no longer necessary. 81 82 The user that is completely sure that Slynk will always be contacted 83 by SLY clients **without** the sly-retro.el contrib, can also set this 84 to NIL in her ~/.swankrc. Generally best left alone.") 85 86 (defun read-form (string package) 87 (with-standard-io-syntax 88 (let ((*package* package)) 89 (if *translating-swank-to-slynk* 90 (with-input-from-string (*standard-input* string) 91 (translating-read)) 92 (read-from-string string))))) 93 94 (defun maybe-convert-package-designator (string) 95 (let ((colon-pos (position #\: string)) 96 (search (search "SWANK" string :test #'char-equal))) 97 (if (and search colon-pos) 98 (nstring-upcase (replace string "SLYNK")) 99 string))) 100 101 (defun translating-read () 102 "Read a form that conforms to the protocol, otherwise signal an error." 103 (flet ((chomp () 104 (loop for ch = (read-char nil t) 105 while (eq ch #\space) 106 finally (unread-char ch)))) 107 (chomp) 108 (let ((c (read-char))) 109 (case c 110 (#\" (with-output-to-string (*standard-output*) 111 (loop for c = (read-char) do 112 (case c 113 (#\" (return)) 114 (#\\ (write-char (read-char))) 115 (t (write-char c)))))) 116 (#\( 117 (chomp) 118 (loop with dotread = nil 119 with retval = nil 120 for read = (read-char) 121 while (case read 122 (#\) nil) 123 (#\. (setq dotread t) t) 124 (t (progn (unread-char read) t))) 125 126 when (eq dotread 'should-error) 127 do (error 'reader-error :format-arguments "Too many things after dot") 128 when dotread 129 do (setq dotread 'should-error) 130 do (setq retval (nconc retval 131 (if dotread 132 (translating-read) 133 (list (translating-read))))) 134 (chomp) 135 finally (return retval))) 136 (#\' `(quote ,(translating-read))) 137 (t (let ((string (with-output-to-string (*standard-output*) 138 (loop for ch = c then (read-char nil nil) do 139 (case ch 140 ((nil) (return)) 141 (#\\ (write-char (read-char))) 142 ((#\" #\( #\space #\)) (unread-char ch)(return)) 143 (t (write-char ch))))))) 144 (read-from-string 145 (maybe-convert-package-designator string)))))))) 146 147 148 ;;;;; Output 149 150 (defun write-message (message package stream) 151 (let* ((string (prin1-to-string-for-emacs message package)) 152 (octets (handler-case (slynk-backend:string-to-utf8 string) 153 (error (c) (encoding-error c string)))) 154 (length (length octets))) 155 (write-header stream length) 156 (write-sequence octets stream) 157 (finish-output stream))) 158 159 ;; FIXME: for now just tell emacs that we and an encoding problem. 160 (defun encoding-error (condition string) 161 (slynk-backend:string-to-utf8 162 (prin1-to-string-for-emacs 163 `(:reader-error 164 ,(asciify string) 165 ,(format nil "Error during string-to-utf8: ~a" 166 (or (ignore-errors (asciify (princ-to-string condition))) 167 (asciify (princ-to-string (type-of condition)))))) 168 (find-package :cl)))) 169 170 (defun write-header (stream length) 171 (declare (type (unsigned-byte 24) length)) 172 ;;(format *trace-output* "length: ~d (#x~x)~%" length length) 173 (loop for c across (format nil "~6,'0x" length) 174 do (write-byte (char-code c) stream))) 175 176 (defun switch-to-double-floats (x) 177 (typecase x 178 (double-float x) 179 (float (coerce x 'double-float)) 180 (null x) 181 (list (loop for (x . cdr) on x 182 collect (switch-to-double-floats x) into result 183 until (atom cdr) 184 finally (return (append result (switch-to-double-floats cdr))))) 185 (t x))) 186 187 (defun prin1-to-string-for-emacs (object package) 188 (with-standard-io-syntax 189 (let ((*print-case* :downcase) 190 (*print-readably* nil) 191 (*print-pretty* nil) 192 (*package* package) 193 ;; Emacs has only double floats. 194 (*read-default-float-format* 'double-float)) 195 (prin1-to-string (switch-to-double-floats object))))) 196 197 198 #| TEST/DEMO: 199 200 (defparameter *transport* 201 (with-output-to-string (out) 202 (write-message '(:message (hello "world")) *package* out) 203 (write-message '(:return 5) *package* out) 204 (write-message '(:emacs-rex NIL) *package* out))) 205 206 *transport* 207 208 (with-input-from-string (in *transport*) 209 (loop while (peek-char T in NIL) 210 collect (read-message in *package*))) 211 212 |#