-
Notifications
You must be signed in to change notification settings - Fork 1
/
trivial-swank.lisp
293 lines (259 loc) · 10.4 KB
/
trivial-swank.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
;; Start a swank server in another instance:
;; (ql:quickload :swank-protocol)
;; (setf swank:*configure-emacs-indentation* nil)
;; (swank:create-server :port 5000 :dont-close t)
;;
;; For convenicence, 'sbcl --load swanker-old.lisp
;;
;; We assume a connection per UI buffer, so history is kept here. History
;; is harder than it looks: the first back just repeats the last one...
;; - after processing rex, null-out history index and set last-rex.
;; - history back/forward on null history, starts with last-rex
(in-package :swa)
;;; prevent reader errors
;;(eval-when (:compile-toplevel :load-toplevel) (swank:swank-require '(swank-presentations swank-repl)))
;;=============================================================================
;; every rex issued is saved along with its execution environment in this
;; structure. we keep it in an array, and use its index as the continuation
;; id for swank. when a return message comes in, we match it up using the id.
;; in addition, this provides a history of forms executed for the ui.
;; note that we store a string representation of the form, to allow gc.
(defstruct rex package form proc)
(defun get-next-id (connection)
"return the next continuation id"
(fill-pointer (rexs connection)))
;;=============================================================================
;; It is useful to log the communications stream...
(defparameter *msg-output* nil)
(defmacro msg (&rest rest)
`(format *msg-output* ,@rest))
;;=============================================================================
(defclass connection ()
((hostname :reader hostname
:accessor hostname
:initarg :hostname
:initform "localhost"
:type string
:documentation "swank host")
(port :reader port
:accessor port
:initarg :port
:initform 4005
:type integer
:documentation "swank port")
(pkg :accessor pkg
:initform "COMMON-LISP-USER"
:type string
:documentation "the name of the connection's package.")
(prompt :accessor prompt
:initform "CL-USER"
:type string
:documentation "prompt to display")
;history
(histid :accessor histid
:initform nil
:type (or null fixnum)
:documentation "history-tracking id")
(rexid :accessor rexid
:initform nil
:type (or null fixnum)
:documentation "last-processed rex id")
(socket :accessor socket
:type usocket:stream-usocket
:documentation "the usocket socket.")
(state :accessor state
:documentation "socket state")
(thr :accessor thr
:initform nil
:documentation "thread used for listening")
(rexs :accessor rexs
:initform nil)
)
(:documentation "a swank protocol connection"))
(defun make-connection (hostname port)
"create a connection to a remote swank server."
(make-instance 'connection
:hostname hostname
:port port))
;;==============================================================================
;; utf-8-safe communication...
;;
;; immediately upon connection, a thread is started to process responses.
;; any forms received that are not processed are sent to fallback
;; (fallback connection forms).
;;
;; Note: waiter thread is started to process responses from the SWANK server.
;; Remeber so bind *standard-output* and *package*!
;;
(defun default-fallback (connection forms)
(declare (ignore connection))
(msg * "~%default connection fallback: ~a~%" forms))
(defun connect (connection &key (fallback #'default-fallback)
out pack)
"connect to the remote server and process requests, sending unknown
forms to fallback processor."
(with-slots (hostname port socket thr rexs histid rexid state) connection
(let ((sock (usocket:socket-connect hostname
port
:element-type '(unsigned-byte 8))))
(setf socket sock
rexs (make-array 100 :adjustable t :fill-pointer 0 )
histid nil
rexid nil
state :connected ;set once!
thr
(bt:make-thread
(lambda ()
(let ((stream (usocket:socket-stream socket))
(*standard-output* out)
(*package* pack))
(loop named waiter do
(usocket:wait-for-input socket :ready-only t :timeout 0.2)
;; socket may have been destroyed
(when (eq state :closing)
(usocket:socket-close socket)
(msg "swank connection closed");;;;
(return-from waiter))
(when (message-waiting-p connection)
(message-process connection
(read-packet stream)
fallback)))))))))
t)
(defun disconnect (connection)
(with-slots (state) connection
(setf state :closing)))
;;==============================================================================
;; low-level packetization.
;; stream is a utf8 byte stream. each message is a utf8 string, prefixed with a
;; 24-bit payload-size count, encoded as 6 ascii bytes.
;;
(defun write-packet (stream string)
"write a string to a stream, prefixing it with length information for swank."
(let* ((payload (utf8-encode string))
(paylen (1+ (length payload)) )
(prefix (utf8-encode (format nil "~6,'0,x" paylen)))
(final (make-array (+ 6 paylen ) :element-type '(unsigned-byte 8)
:initial-element 32;(char-code #\newline);;TODO***
)))
(replace final prefix); insert 6 bytes of length
(replace final payload :start1 6)
(write-sequence final stream)
(msg ">>>[~A]~&" string)
string))
(defun read-packet (stream)
"read a swank packet and convert payload to a lisp string."
(let ((arr (make-array 6 :element-type '(unsigned-byte 8))))
(read-sequence arr stream)
(let ((paylen (parse-integer (utf8-decode arr) :radix 16)))
(setf arr (make-array paylen :element-type '(unsigned-byte 8)))
(read-sequence arr stream)
(let ((val (utf8-decode arr)))
(msg "<<<[~A]~&" val)
val))))
;;==============================================================================
;; Sending strings (we always receive packets)
(defun send-message-string (connection string)
"send a message string to a swank connection."
(let ((stream (usocket:socket-stream (socket connection))))
(prog1 (write-packet stream string)
(force-output stream))))
(defun message-waiting-p (connection)
"t if there's a message in the connection waiting to be read, nil otherwise."
(usocket:wait-for-input (socket connection)
:ready-only t
:timeout 0))
;;==============================================================================
;;; rex
;;
;; All rex requests are kept in rex structures in rexs array, along with the
;; lambda to process them. That is how we handle 'continuation' issues.
;; Null requests are OK.
(defun default-rex-proc (connection reply id);rex-callback
(declare (ignore connection))
(msg "~%default swank reply handler for id ~a: ~a~&" id reply))
;;------------------------------------------------------------------------------
;; generic rex requests have the form thrown out
(defun emacs-rex (connection string &key (proc #'default-rex-proc) (thread t))
(when string
(with-slots (pkg rexs) connection
(send-message-string
connection
(format nil "(:emacs-rex ~a ~s ~a ~a)"
string
pkg
thread
(fill-pointer rexs)))
(vector-push (make-rex :package pkg :form nil :proc proc) rexs))))
;;------------------------------------------------------------------------------
;; eval in repl requests are saved in rex array.
(defun eval (connection string &optional (proc #'default-rex-proc))
"request a swank repl eval and return the id"
(when string
(with-slots (pkg rexs) connection
(send-message-string
connection
(format nil "(:emacs-rex (swank-repl:listener-eval ~s) ~s :repl-thread ~a)"
string pkg (fill-pointer rexs)))
(vector-push (make-rex :package pkg :form string :proc proc) rexs))))
;;
;;
;;==============================================================================
;; non-rex
;;
;; this one is for read-line...
(defun emacs-return-string (connection string id tag )
"send a string to the server's standard input, appending a newline"
(send-message-string
connection
(format nil "(:emacs-return-string ~a ~a \"~a~&\")" id tag string)))
;;==============================================================================
;; the receiver thread runs this to process messages from swank.
;; message is read, and the sexp is processed as follows:
;; - return messages are matched up with the request, and proc is called.
;; - otherwise, fallback provided by the owner is called as
;; (... connection message)
(defun message-process (connection message-str fallback)
"process a message string."
(with-slots (rexs histid rexid) connection
(let ((message (read-from-string message-str)))
(case (first message)
(:return ;match it with the request
;; (:return (ok/abort data) id)
(destructuring-bind (reply id) (cdr message)
(let ((rex (aref rexs id)))
(funcall (rex-proc rex) connection reply id)
(setf rexid id; remember last rex processed
histid nil))));and reset history
(t (funcall fallback connection message)))))
)
;;==============================================================================
;; History is surprisingly difficult: first time back, we repeat the last rex,
;; after that, we go to previous. Because of that we have to maintain an
;; 'pipeline' that catches the first-time attempt to get history without
;; incrementing/decrementing.
(defun get-historical-line (connection id)
(rex-form (aref (rexs connection) id)))
(defun history-back (connection)
"return prev historical string"
(with-slots (histid rexid) connection
(if histid ;if there is history, decrement
(when (> histid 0)
(setf histid
(loop for i from (1- histid) downto 0
until (get-historical-line connection i)
finally (return i)
if (zerop i) return histid)))
(setf histid rexid)) ;otherwise, start with last one.
(get-historical-line connection histid)))
(defun history-forward (connection)
(with-slots (histid rexid) connection
(if histid
(let ((upper (get-next-id connection)))
(when (> upper (1+ histid))
(setf histid ;here, try to increment as we don't need this one...
(loop for i from (1+ histid) upto upper
until (get-historical-line connection i)
finally (return i)
if (= i upper) return histid))))
(setf histid rexid))
(get-historical-line connection histid)))