swank-rpc.lisp 5.37 KB
Newer Older
1
;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*-
2 3 4 5 6 7 8 9 10
;;;
;;; swank-rpc.lisp  -- Pass remote calls and responses between lisp systems.
;;;
;;; Created 2010, Terje Norderhaug <terje@in-progress.com>
;;;
;;; This code has been placed in the Public Domain.  All warranties
;;; are disclaimed.
;;;

11
(defpackage #:swank-rpc
12
  (:use :cl)
tnorderhaug's avatar
tnorderhaug committed
13
  (:export 
14 15 16 17 18
   #:read-message
   #:swank-reader-error
   #:swank-reader-error.packet
   #:swank-reader-error.cause
   #:write-message))
tnorderhaug's avatar
tnorderhaug committed
19 20

(in-package :swank-rpc)
21

22

23 24
;;;;; Input

25
(define-condition swank-reader-error (reader-error)
Helmut Eller's avatar
Helmut Eller committed
26 27 28 29
  ((packet :type string :initarg :packet 
           :reader swank-reader-error.packet)
   (cause :type reader-error :initarg :cause 
          :reader swank-reader-error.cause)))
30 31 32 33 34

(defun read-message (stream package)
  (let ((packet (read-packet stream)))
    (handler-case (values (read-form packet package))
      (reader-error (c)
Helmut Eller's avatar
Helmut Eller committed
35 36
        (error (make-condition 'swank-reader-error 
                               :packet packet :cause c))))))
37 38

(defun read-packet (stream)
39 40 41 42 43 44 45
  (let* ((length (parse-header stream))
         (octets (read-chunk stream length)))
    (handler-case (swank-backend:utf8-to-string octets)
      (error (c) 
        (error (make-condition 'swank-reader-error 
                               :packet (asciify octets)
                               :cause c))))))
Helmut Eller's avatar
Helmut Eller committed
46 47 48 49 50 51 52 53 54 55

(defun asciify (packet)
  (with-output-to-string (*standard-output*)
    (loop for code across (etypecase packet 
                            (string (map 'vector #'char-code packet))
                            (vector packet))
          do (cond ((<= code #x7f) (write-char (code-char code)))
                   (t (format t "\\x~x" code))))))

(defun parse-header (stream)
56 57 58
  (parse-integer (map 'string #'code-char (read-chunk stream 6))
                 :radix 16))

59
(defun read-chunk (stream length)
Helmut Eller's avatar
Helmut Eller committed
60
  (let* ((buffer (make-array length :element-type '(unsigned-byte 8)))
61
         (count (read-sequence buffer stream)))
62 63 64 65 66 67
    (cond ((= count length)
           buffer)
          ((zerop count)
           (error (make-condition 'end-of-file :stream stream)))
          (t
           (error "Short read: length=~D  count=~D" length count)))))
68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83

;; FIXME: no one ever tested this and will probably not work.
(defparameter *validate-input* nil
  "Set to true to require input that strictly conforms to the protocol")

(defun read-form (string package)
  (with-standard-io-syntax
    (let ((*package* package))
      (if *validate-input*
          (validating-read string)
          (read-from-string string)))))

(defun validating-read (string)
  (with-input-from-string (*standard-input* string)
    (simple-read)))

84
(defun simple-read ()
85
   "Read a form that conforms to the protocol, otherwise signal an error."
86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108
   (let ((c (read-char)))
     (case c
       (#\" (with-output-to-string (*standard-output*)
              (loop for c = (read-char) do
                    (case c
                      (#\" (return))
                      (#\\ (write-char (read-char)))
                      (t (write-char c))))))
       (#\( (loop collect (simple-read)
                  while (ecase (read-char)
                          (#\) nil)
                          (#\space t))))
       (#\' `(quote ,(simple-read)))
       (t (let ((string (with-output-to-string (*standard-output*)
                          (loop for ch = c then (read-char nil nil) do
                                (case ch
                                  ((nil) (return))
                                  (#\\ (write-char (read-char)))
                                  ((#\space #\)) (unread-char ch)(return))
                                  (t (write-char ch)))))))
            (cond ((digit-char-p c) (parse-integer string))
                  ((intern string))))))))

109

110 111
;;;;; Output

112 113
(defun write-message (message package stream)
  (let* ((string (prin1-to-string-for-emacs message package))
Helmut Eller's avatar
Helmut Eller committed
114 115 116
         (octets (handler-case (swank-backend:string-to-utf8 string)
                   (error (c) (encoding-error c string))))
         (length (length octets)))
117
    (write-header stream length)
Helmut Eller's avatar
Helmut Eller committed
118
    (write-sequence octets stream)
119
    (finish-output stream)))
120

Helmut Eller's avatar
Helmut Eller committed
121 122 123 124 125 126 127 128 129 130 131
;; FIXME: for now just tell emacs that we and an encoding problem.
(defun encoding-error (condition string)
  (swank-backend:string-to-utf8
   (prin1-to-string-for-emacs
    `(:reader-error
      ,(asciify string)
      ,(format nil "Error during string-to-utf8: ~a"
               (or (ignore-errors (asciify (princ-to-string condition)))
                   (asciify (princ-to-string (type-of condition))))))
    (find-package :cl))))

132 133 134 135 136
(defun write-header (stream length)
  (declare (type (unsigned-byte 24) length))
  ;;(format *trace-output* "length: ~d (#x~x)~%" length length)
  (loop for c across (format nil "~6,'0x" length)
        do (write-byte (char-code c) stream)))
Helmut Eller's avatar
Helmut Eller committed
137

138
(defun prin1-to-string-for-emacs (object package)
139 140 141 142
  (with-standard-io-syntax
    (let ((*print-case* :downcase)
          (*print-readably* nil)
          (*print-pretty* nil)
143
          (*package* package))
144 145
      (prin1-to-string object))))

146

147 148 149 150
#| TEST/DEMO:

(defparameter *transport*
  (with-output-to-string (out)
151 152 153
    (write-message '(:message (hello "world")) *package* out)
    (write-message '(:return 5) *package* out)
    (write-message '(:emacs-rex NIL) *package* out)))
154 155 156 157 158

*transport*
                 
(with-input-from-string (in *transport*)
  (loop while (peek-char T in NIL)
159
        collect (read-message in *package*)))
160 161

|#