/
resource.lisp
255 lines (221 loc) · 10.3 KB
/
resource.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
(in-package #:ws)
;;; resource stuff
;;;
;;; name ("/foo", etc)
;;;
;;; accept function
;;; args = resource name, headers, client host/port
;;; return
;;; reject connection
;;; abort connection?
;;; ? for accepted
;; fixme: make this per-server, so we can run different servers on
;; different ports?
;; fixme: add support for more complex matching than just exact match
(defparameter *resources* (make-hash-table :test 'equal)
"hash mapping resource name to (list of handler instance, origin
validation function, ?)")
(defun register-global-resource (name resource-handler origin-validation-fn)
"Registers a resource instance where NAME is a path string like
'/swank', resource-handler is an instance of WS-RESOURCE, and
ORIGIN-VALIDATION-FN is a function that takes an origin string as
input and returns T if that origin is allowed to access this
resource."
(setf (gethash name *resources*)
(list resource-handler origin-validation-fn)))
(defun find-global-resource (name)
"Returns the resource registered via REGISTER-GLOBAL-RESOURCE with name NAME."
(first (gethash name *resources*)))
(defun unregister-global-resource (name)
"Removes the resource registered via REGISTER-GLOBAL-RESOURCE with name NAME."
(remhash name *resources*))
(defun valid-resource-p (server resource)
"Returns non-nil if there is a handler registered for the resource
of the given name (a string)."
(declare (type string resource)
(ignore server))
(when resource
(gethash resource *resources*)))
;; functions for checking origins...
(defun any-origin (o) (declare (ignore o)) t)
(defun origin-prefix (&rest prefixes)
"Returns a function that checks whether a given path matches any of
the prefixes passed as arguments."
(lambda (o)
(loop :for p :in prefixes
:for m = (mismatch o p)
:when (or (not m) (= m (length p)))
:return t)))
(defun origin-exact (&rest origins)
"Returns a function that checks whether a given path matches any of
the origins passed as arguments exactly."
;; fixme: probably should use something better than a linear search
(lambda (o)
(member o origins :test #'string=)))
(defgeneric resource-read-queue (resource)
(:documentation "The concurrent mailbox used to pass messages
between the server thread and resource thread."))
(defclass ws-resource ()
((read-queue :initform (make-mailbox) :reader resource-read-queue))
(:documentation "A server may have many resources, each associated
with a particular resource path (like /echo or /chat). An single
instance of a resource handles all requests on the server for that
particular url, with the help of RUN-RESOURCE-LISTENER,
RESOURCE-RECEIVED-FRAME, and RESOURCE-CLIENT-DISCONNECTED."))
(defgeneric resource-accept-connection (res resource-name headers client)
(:documentation "Decides whether to accept a connection and returns
values to process the connection further. Defaults to accepting all
connections and using the default mailbox and origin, so most resources
shouldn't need to define a method.
Passed values
- RES is the instance of ws-resource
- RESOURCE-NAME is the resource name requested by the client (string)
- HEADERS is the hash table of headers from the client
- client is the instance of client
Returns values
1. NIL if the connection should be rejected, or non-nil otherwise
2. Concurrent mailbox in which to place messages received from the
client, or NIL for default
3. origin from which to claim this resource is responding, or NIL
for default.
4. handshake-resource or NIL for default
5. protocol or NIL for default
Most of the time this function will just return true for the first
value to accept the connection, and nil for the other values.
Note that the connection is not fully established yet, so this
function should not try to send anything to the client, see
resource-client-connected for that.
This function may be called from a different thread than most resource
functions, so methods should be careful about accessing shared data, and
should avoid blocking for extended periods.
"))
(defgeneric resource-client-disconnected (resource client)
(:documentation "Called when a client disconnected from a WebSockets resource."))
(defgeneric resource-client-connected (resource client)
(:documentation "Called when a client finishes connecting to a
WebSockets resource, and data can be sent to the client.
Methods can return :reject to immediately close the connection and
ignore any already received data from this client."))
#++
(defgeneric resource-received-frame (resource client message)
;;; not used for the moment, since newer ws spec combine 'frame's into
;;; 'message's, which might be binary or text...
;;; may add this back later as an interface to processing per frame
;;; instead of per message?
(:documentation "Called when a client sent a frame to a WebSockets resource."))
(defgeneric resource-received-text (resource client message)
(:documentation "Called when a client sent a text message to a WebSockets resource."))
(defgeneric resource-received-binary (resource client message)
(:documentation "Called when a client sent a binary message to a WebSockets resource."))
(defgeneric resource-received-custom-message (resource message)
(:documentation "Called on the resource listener thread when a
client is passed an arbitrary message via
SEND-CUSTOM-MESSAGE-TO-RESOURCE. "))
(defgeneric send-custom-message-to-resource (resource message)
(:documentation "Thread-safe way to pass a message to the resource
listener. Any message passed with this function will result in
RESOURCE-RECEIVED-CUSTOM-MESSAGE being called on the resource thread
with the second argument of this function."))
(defmethod resource-accept-connection (res resource-name headers client)
(declare (ignore res resource-name headers client))
t)
(defmethod resource-client-connected (res client)
(declare (ignore res client))
nil)
(defmethod send-custom-message-to-resource (resource message)
(mailbox-send-message (resource-read-queue resource)
(list message :custom)))
(defclass funcall-custom-message ()
((function :initarg :function :initform nil :reader message-function))
(:documentation "A type of so-called 'custom message' used to call a
function on the main resource thread."))
(defmethod resource-received-custom-message (resource (message funcall-custom-message))
(declare (ignore resource))
(funcall (message-function message)))
(defgeneric call-on-resource-thread (resource fn)
(:documentation "Funcalls FN on the resource thread of RESOURCE."))
(defmethod call-on-resource-thread (resource fn)
(send-custom-message-to-resource
resource (make-instance 'funcall-custom-message :function fn)))
(defun disconnect-client (client)
(when (client-resource client)
(resource-client-disconnected (client-resource client) client)
(setf (client-resource client) nil)))
(defun run-resource-listener (resource)
"Runs a resource listener in its own thread indefinitely, calling
RESOURCE-CLIENT-DISCONNECTED and RESOURCE-RECEIVED-FRAME as appropriate."
(macrolet
((restarts (&body body)
`(handler-bind
((error
(lambda (c)
(cond
(*debug-on-resource-errors*
(invoke-debugger c))
(t
(lg "resource handler error ~s, dropping client~%" c)
(invoke-restart 'drop-client))))))
(restart-case
(progn ,@body)
(drop-client ()
(unless (client-connection-rejected client)
(ignore-errors (disconnect-client client)))
;; none of the defined status codes in draft 14 seem right for
;; 'server error'
(ignore-errors (write-to-client-close client :code nil))
(setf (client-connection-rejected client) t))
(drop-message () #|| do nothing ||#)))))
(loop :for (client data) = (mailbox-receive-message (slot-value resource 'read-queue))
;; fixme should probably call some generic function with all
;; the remaining messages
:while (not (eql data :close-resource))
:do
(cond
((eql data :custom)
;; here we use the client place to store the custom message
(handler-bind
((error
(lambda (c)
(cond
(*debug-on-resource-errors*
(invoke-debugger c))
(t
(lg "resource handler error ~s in custom, ignoring~%" c)
(invoke-restart 'continue))))))
(let ((message client))
(restart-case
(resource-received-custom-message resource message)
(continue () :report "Continue" )))))
((and client (client-connection-rejected client))
#|| ignore any further queued data from this client ||#)
((eql data :connect)
(restarts
(when (eq :reject (resource-client-connected resource client))
(setf (client-connection-rejected client) t)
(write-to-client-close client))))
((eql data :eof)
(restarts
(disconnect-client client))
(write-to-client-close client))
((eql data :dropped)
(restarts
(disconnect-client client))
(write-to-client-close client))
((eql data :close-resource)
(restarts
(disconnect-client client)))
((eql data :flow-control)
(%write-to-client client :enable-read))
((symbolp data)
(error "Unknown symbol in read-queue of resource: ~S " data))
((consp data)
(restarts
(if (eq (car data) :text)
(resource-received-text resource client (cadr data))
(resource-received-binary resource client (cadr data)))))
(t
(error "got unknown data in run-resource-listener?"))))))
(defun kill-resource-listener (resource)
"Terminates a RUN-RESOURCE-LISTENER from another thread."
(mailbox-send-message (resource-read-queue resource)
'(nil :close-resource)))