1 ;;; websocket.el --- Emacs WebSocket client and server
3 ;; Copyright (c) 2013 Free Software Foundation, Inc.
5 ;; Author: Andrew Hyatt <ahyatt at gmail dot com>
6 ;; Maintainer: Andrew Hyatt <ahyatt at gmail dot com>
7 ;; Keywords: Communication, Websocket, Server
10 ;; This program is free software; you can redistribute it and/or
11 ;; modify it under the terms of the GNU General Public License as
12 ;; published by the Free Software Foundation; either version 3 of the
13 ;; License, or (at your option) any later version.
15 ;; This program is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 ;; This implements RFC 6455, which can be found at
25 ;; http://tools.ietf.org/html/rfc6455.
27 ;; This library contains code to connect Emacs as a client to a
28 ;; websocket server, and for Emacs to act as a server for websocket
31 ;; Websockets clients are created by calling `websocket-open', which
32 ;; returns a `websocket' struct. Users of this library use the
33 ;; websocket struct, and can call methods `websocket-send-text', which
34 ;; sends text over the websocket, or `websocket-send', which sends a
35 ;; `websocket-frame' struct, enabling finer control of what is sent.
36 ;; A callback is passed to `websocket-open' that will retrieve
37 ;; websocket frames called from the websocket. Websockets are
38 ;; eventually closed with `websocket-close'.
40 ;; Server functionality is similar. A server is started with
41 ;; `websocket-server' called with a port and the callbacks to use,
42 ;; which returns a process. The process can later be closed with
43 ;; `websocket-server-close'. A `websocket' struct is also created
44 ;; for every connection, and is exposed through the callbacks.
48 (eval-when-compile (require 'cl))
54 (:constructor websocket-inner-create))
55 "A websocket structure.
56 This follows the W3C Websocket API, except translated to elisp
57 idioms. The API is implemented in both the websocket struct and
58 additional methods. Due to how defstruct slots are accessed, all
59 API methods are prefixed with \"websocket-\" and take a websocket
60 as an argument, so the distrinction between the struct API and
61 the additional helper APIs are not visible to the caller.
63 A websocket struct is created with `websocket-open'.
65 `ready-state' contains one of 'connecting, 'open, or
66 'closed, depending on the state of the websocket.
68 The W3C API \"bufferedAmount\" call is not currently implemented,
69 since there is no elisp API to get the buffered amount from the
70 subprocess. There may, in fact, be output data buffered,
71 however, when the `on-message' or `on-close' callbacks are
74 `on-open', `on-message', `on-close', and `on-error' are described
77 The `negotiated-extensions' slot lists the extensions accepted by
78 both the client and server, and `negotiated-protocols' does the
79 same for the protocols.
82 (ready-state 'connecting)
90 (server-p nil :read-only t)
92 ;; Other data - clients should not have to access this.
93 (url (assert nil) :read-only t)
94 (protocols nil :read-only t)
95 (extensions nil :read-only t)
96 (conn (assert nil) :read-only t)
97 ;; Only populated for servers, this is the server connection.
100 (inflight-input nil))
102 (defvar websocket-version "1.1"
103 "Version numbers of this version of websocket.el.")
105 (defvar websocket-debug nil
106 "Set to true to output debugging info to a per-websocket buffer.
107 The buffer is ` *websocket URL debug*' where URL is the
108 URL of the connection.")
110 (defconst websocket-guid "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
111 "The websocket GUID as defined in RFC 6455.
112 Do not change unless the RFC changes.")
114 (defvar websocket-mask-frames t
115 "If true, we mask frames as defined in the spec.
116 This is recommended to be true, and some servers will refuse to
117 communicate with unmasked clients.")
119 (defvar websocket-callback-debug-on-error nil
120 "If true, when an error happens in a client callback, invoke the debugger.
121 Having this on can cause issues with missing frames if the debugger is
122 exited by quitting instead of continuing, so it's best to have this set
123 to nil unless it is especially needed.")
125 (defmacro websocket-document-function (function docstring)
126 "Document FUNCTION with DOCSTRING. Use this for defstruct accessor etc."
127 (declare (indent defun)
129 `(put ',function 'function-documentation ,docstring))
131 (websocket-document-function websocket-on-open
132 "Accessor for websocket on-open callback.
133 See `websocket-open' for details.
137 (websocket-document-function websocket-on-message
138 "Accessor for websocket on-message callback.
139 See `websocket-open' for details.
143 (websocket-document-function websocket-on-close
144 "Accessor for websocket on-close callback.
145 See `websocket-open' for details.
149 (websocket-document-function websocket-on-error
150 "Accessor for websocket on-error callback.
151 See `websocket-open' for details.
155 (defun websocket-genbytes (nbytes)
156 "Generate NBYTES random bytes."
157 (let ((s (make-string nbytes ?\s)))
159 (aset s i (random 256)))
162 (defun websocket-try-callback (websocket-callback callback-type websocket
164 "Invoke function WEBSOCKET-CALLBACK with WEBSOCKET and REST args.
165 If an error happens, it is handled according to
166 `websocket-callback-debug-on-error'."
167 ;; This looks like it should be able to done more efficiently, but
168 ;; I'm not sure that's the case. We can't do it as a macro, since
169 ;; we want it to change whenever websocket-callback-debug-on-error
172 (debug-on-error websocket-callback-debug-on-error))
173 (push websocket args)
174 (if websocket-callback-debug-on-error
176 (apply (funcall websocket-callback websocket) args)
177 ((debug error) (funcall (websocket-on-error websocket)
178 websocket callback-type err)))
180 (apply (funcall websocket-callback websocket) args)
181 (error (funcall (websocket-on-error websocket) websocket
182 callback-type err))))))
184 (defun websocket-genkey ()
185 "Generate a key suitable for the websocket handshake."
186 (base64-encode-string (websocket-genbytes 16)))
188 (defun websocket-calculate-accept (key)
189 "Calculate the expect value of the accept header.
190 This is based on the KEY from the Sec-WebSocket-Key header."
191 (base64-encode-string
192 (sha1 (concat key websocket-guid) nil nil t)))
194 (defun websocket-get-bytes (s n)
195 "From string S, retrieve the value of N bytes.
196 Return the value as an unsigned integer. The value N must be a
199 We support getting frames up to 536870911 bytes (2^29 - 1),
200 approximately 537M long."
203 (bindat-get-field (bindat-unpack '((:val vec 2 u32)) s) :val))
205 (logior (lsh (aref 32-bit-parts 0) 32) (aref 32-bit-parts 1))))
206 (if (and (= (aref 32-bit-parts 0) 0)
207 (= (lsh (aref 32-bit-parts 1) -29) 0))
209 (signal 'websocket-unparseable-frame
210 "Frame value found too large to parse!")))
219 ;; This is an error with the library,
220 ;; not a user-facing, meaningful error.
222 "websocket-get-bytes: Unknown N: %s" n)))))
224 (args-out-of-range (signal 'websocket-unparseable-frame
225 (format "Frame unexpectedly shortly: %s" s))))
228 (defun websocket-to-bytes (val nbytes)
229 "Encode the integer VAL in NBYTES of data.
230 NBYTES much be a power of 2, up to 8.
232 This supports encoding values up to 536870911 bytes (2^29 - 1),
233 approximately 537M long."
234 (when (and (< nbytes 8)
235 (> val (expt 2 (* 8 nbytes))))
236 ;; not a user-facing error, this must be caused from an error in
238 (error "websocket-to-bytes: Value %d could not be expressed in %d bytes"
242 (let ((hi-32bits (lsh val -32))
243 (low-32bits (logand #xffffffff val)))
244 (when (or (> hi-32bits 0) (> (lsh low-32bits -29) 0))
245 (signal 'websocket-frame-too-large val))
246 (bindat-pack `((:val vec 2 u32))
247 `((:val . [,hi-32bits ,low-32bits])))))
249 `((:val ,(cond ((= nbytes 1) 'u8)
252 ;; Library error, not system error
253 (t (error "websocket-to-bytes: Unknown NBYTES: %s" nbytes)))))
256 (defun websocket-get-opcode (s)
257 "Retrieve the opcode from first byte of string S."
258 (websocket-ensure-length s 1)
259 (let ((opcode (logand #xf (websocket-get-bytes s 1))))
260 (cond ((= opcode 0) 'continuation)
262 ((= opcode 2) 'binary)
263 ((= opcode 8) 'close)
265 ((= opcode 10) 'pong))))
267 (defun websocket-get-payload-len (s)
268 "Parse out the payload length from the string S.
269 We start at position 0, and return a cons of the payload length and how
270 many bytes were consumed from the string."
271 (websocket-ensure-length s 1)
272 (let* ((initial-val (logand 127 (websocket-get-bytes s 1))))
273 (cond ((= initial-val 127)
274 (websocket-ensure-length s 9)
275 (cons (websocket-get-bytes (substring s 1) 8) 9))
277 (websocket-ensure-length s 3)
278 (cons (websocket-get-bytes (substring s 1) 2) 3))
279 (t (cons initial-val 1)))))
281 (defstruct websocket-frame opcode payload length completep)
283 (defun websocket-mask (key data)
284 "Using string KEY, mask string DATA according to the RFC.
285 This is used to both mask and unmask data."
288 (loop for b across data
289 for i from 0 to (length data)
290 collect (logxor (websocket-get-bytes (substring key (mod i 4)) 1) b))))
292 (defun websocket-ensure-length (s n)
293 "Ensure the string S has at most N bytes.
294 Otherwise we throw the error `websocket-incomplete-frame'."
295 (when (< (length s) n)
296 (throw 'websocket-incomplete-frame nil)))
298 (defun websocket-encode-frame (frame)
299 "Encode the FRAME struct to the binary representation."
300 (let* ((opcode (websocket-frame-opcode frame))
301 (payload (websocket-frame-payload frame))
302 (fin (websocket-frame-completep frame))
303 (payloadp (memq opcode '(continuation text binary)))
304 (mask-key (when websocket-mask-frames (websocket-genbytes 4))))
305 (apply 'unibyte-string
307 (logior (cond ((eq opcode 'continuation) 0)
308 ((eq opcode 'text) 1)
309 ((eq opcode 'binary) 2)
310 ((eq opcode 'close) 8)
311 ((eq opcode 'ping) 9)
312 ((eq opcode 'pong) 10))
317 (if websocket-mask-frames 128 0)
318 (cond ((< (length payload) 126) (length payload))
319 ((< (length payload) 65536) 126)
321 (when (and payloadp (>= (length payload) 126))
322 (append (websocket-to-bytes (length payload)
323 (cond ((< (length payload) 126) 1)
324 ((< (length payload) 65536) 2)
326 (when (and payloadp websocket-mask-frames)
327 (append mask-key nil))
329 (append (if websocket-mask-frames
330 (websocket-mask mask-key payload)
334 (defun websocket-read-frame (s)
335 "Read from string S a `websocket-frame' struct with the contents.
336 This only gets complete frames. Partial frames need to wait until
337 the frame finishes. If the frame is not completed, return NIL."
338 (catch 'websocket-incomplete-frame
339 (websocket-ensure-length s 1)
340 (let* ((opcode (websocket-get-opcode s))
341 (fin (logand 128 (websocket-get-bytes s 1)))
342 (payloadp (memq opcode '(continuation text binary)))
343 (payload-len (when payloadp
344 (websocket-get-payload-len (substring s 1))))
347 (= 128 (logand 128 (websocket-get-bytes (substring s 1) 1)))))
348 (payload-start (when payloadp (+ (if maskp 5 1) (cdr payload-len))))
349 (payload-end (when payloadp (+ payload-start (car payload-len))))
350 (unmasked-payload (when payloadp
351 (websocket-ensure-length s payload-end)
352 (substring s payload-start payload-end))))
353 (make-websocket-frame
357 (let ((masking-key (substring s (+ 1 (cdr payload-len))
358 (+ 5 (cdr payload-len)))))
359 (websocket-mask masking-key unmasked-payload))
361 :length (if payloadp payload-end 1)
362 :completep (> fin 0)))))
364 (defun websocket-format-error (err)
365 "Format an error message like command level does.
366 ERR should be a cons of error symbol and error data."
368 ;; Formatting code adapted from `edebug-report-error'
369 (concat (or (get (car err) 'error-message)
370 (format "peculiar error (%s)" (car err)))
373 (mapconcat #'prin1-to-string
376 (defun websocket-default-error-handler (_websocket type err)
377 "The default error handler used to handle errors in callbacks."
378 (display-warning 'websocket
379 (format "in callback `%S': %s"
381 (websocket-format-error err))
384 ;; Error symbols in use by the library
385 (put 'websocket-unsupported-protocol 'error-conditions
386 '(error websocket-error websocket-unsupported-protocol))
387 (put 'websocket-unsupported-protocol 'error-message "Unsupported websocket protocol")
388 (put 'websocket-wss-needs-emacs-24 'error-conditions
389 '(error websocket-error websocket-unsupported-protocol
390 websocket-wss-needs-emacs-24))
391 (put 'websocket-wss-needs-emacs-24 'error-message
392 "wss protocol is not supported for Emacs before version 24.")
393 (put 'websocket-received-error-http-response 'error-conditions
394 '(error websocket-error websocket-received-error-http-response))
395 (put 'websocket-received-error-http-response 'error-message
396 "Error response received from websocket server")
397 (put 'websocket-invalid-header 'error-conditions
398 '(error websocket-error websocket-invalid-header))
399 (put 'websocket-invalid-header 'error-message
400 "Invalid HTTP header sent")
401 (put 'websocket-illegal-frame 'error-conditions
402 '(error websocket-error websocket-illegal-frame))
403 (put 'websocket-illegal-frame 'error-message
404 "Cannot send illegal frame to websocket")
405 (put 'websocket-closed 'error-conditions
406 '(error websocket-error websocket-closed))
407 (put 'websocket-closed 'error-message
408 "Cannot send message to a closed websocket")
409 (put 'websocket-unparseable-frame 'error-conditions
410 '(error websocket-error websocket-unparseable-frame))
411 (put 'websocket-unparseable-frame 'error-message
412 "Received an unparseable frame")
413 (put 'websocket-frame-too-large 'error-conditions
414 '(error websocket-error websocket-frame-too-large))
415 (put 'websocket-frame-too-large 'error-message
416 "The frame being sent is too large for this emacs to handle")
418 (defun websocket-intersect (a b)
419 "Simple list intersection, should function like Common Lisp's `intersection'."
421 (dolist (elem a (nreverse result))
422 (when (member elem b)
423 (push elem result)))))
425 (defun websocket-get-debug-buffer-create (websocket)
426 "Get or create the buffer corresponding to WEBSOCKET."
427 (let ((buf (get-buffer-create (format "*websocket %s debug*"
428 (websocket-url websocket)))))
429 (when (= 0 (buffer-size buf))
430 (buffer-disable-undo buf))
433 (defun websocket-debug (websocket msg &rest args)
434 "In the WEBSOCKET's debug buffer, send MSG, with format ARGS."
435 (when websocket-debug
436 (let ((buf (websocket-get-debug-buffer-create websocket)))
438 (with-current-buffer buf
439 (goto-char (point-max))
441 (insert (apply 'format (append (list msg) args)))
444 (defun websocket-verify-response-code (output)
445 "Verify that OUTPUT contains a valid HTTP response code.
446 The only acceptable one to websocket is responce code 101.
447 A t value will be returned on success, and an error thrown
449 (string-match "HTTP/1.1 \\([[:digit:]]+\\)" output)
450 (unless (equal "101" (match-string 1 output))
451 (signal 'websocket-received-error-http-response
452 (string-to-number (match-string 1 output))))
455 (defun websocket-parse-repeated-field (output field)
456 "From header-containing OUTPUT, parse out the list from a
457 possibly repeated field."
461 (string-match (format "\r\n%s: \\(.*\\)\r\n" field)
463 (when (setq pos (match-end 1))
464 (setq extensions (append extensions (split-string
465 (match-string 1 output) ", ?")))))
468 (defun websocket-process-frame (websocket frame)
469 "Using the WEBSOCKET's filter and connection, process the FRAME.
470 This returns a lambda that should be executed when all frames have
471 been processed. If the frame has a payload, the lambda has the frame
472 passed to the filter slot of WEBSOCKET. If the frame is a ping,
473 the lambda has a reply with a pong. If the frame is a close, the lambda
474 has connection termination."
475 (let ((opcode (websocket-frame-opcode frame)))
476 (lexical-let ((lex-ws websocket)
478 (cond ((memq opcode '(continuation text binary))
479 (lambda () (websocket-try-callback 'websocket-on-message 'on-message
482 (lambda () (websocket-send lex-ws
483 (make-websocket-frame :opcode 'pong :completep t))))
485 (lambda () (delete-process (websocket-conn lex-ws))))
488 (defun websocket-process-input-on-open-ws (websocket text)
489 "This handles input processing for both the client and server filters."
490 (let ((current-frame)
493 (while (setq current-frame (websocket-read-frame
494 (substring text start-point)))
495 (push (websocket-process-frame websocket current-frame) processing-queue)
496 (incf start-point (websocket-frame-length current-frame)))
497 (when (> (length text) start-point)
498 (setf (websocket-inflight-input websocket)
499 (substring text start-point)))
500 (dolist (to-process (nreverse processing-queue))
501 (funcall to-process))))
503 (defun websocket-send-text (websocket text)
504 "To the WEBSOCKET, send TEXT as a complete frame."
507 (make-websocket-frame :opcode 'text
508 :payload (encode-coding-string
512 (defun websocket-check (frame)
513 "Check FRAME for correctness, returning true if correct."
514 (and (equal (not (memq (websocket-frame-opcode frame)
515 '(continuation text binary)))
516 (and (not (websocket-frame-payload frame))
517 (websocket-frame-completep frame)))))
519 (defun websocket-send (websocket frame)
520 "To the WEBSOCKET server, send the FRAME.
521 This will raise an error if the frame is illegal.
523 The error signaled may be of type `websocket-illegal-frame' if
524 the frame is malformed in some way, also having the condition
525 type of `websocket-error'. The data associated with the signal
526 is the frame being sent.
528 If the websocket is closed a signal `websocket-closed' is sent,
529 also with `websocket-error' condition. The data in the signal is
532 The frame may be too large for this buid of Emacs, in which case
533 `websocket-frame-too-large' is returned, with the data of the
534 size of the frame which was too large to process. This also has
535 the `websocket-error' condition."
536 (unless (websocket-check frame)
537 (signal 'websocket-illegal-frame frame))
538 (websocket-debug websocket "Sending frame, opcode: %s payload: %s"
539 (websocket-frame-opcode frame)
540 (websocket-frame-payload frame))
541 (websocket-ensure-connected websocket)
542 (unless (websocket-openp websocket)
543 (signal 'websocket-closed frame))
544 (process-send-string (websocket-conn websocket)
545 (websocket-encode-frame frame)))
547 (defun websocket-openp (websocket)
548 "Check WEBSOCKET and return non-nil if it is open, and either
551 (not (eq 'close (websocket-ready-state websocket)))
552 (member (process-status (websocket-conn websocket)) '(open run))))
554 (defun websocket-close (websocket)
555 "Close WEBSOCKET and erase all the old websocket data."
556 (websocket-debug websocket "Closing websocket")
557 (when (websocket-openp websocket)
558 (websocket-send websocket
559 (make-websocket-frame :opcode 'close
561 (setf (websocket-ready-state websocket) 'closed))
562 (let ((buf (process-buffer (websocket-conn websocket))))
563 (delete-process (websocket-conn websocket))
566 (defun websocket-ensure-connected (websocket)
567 "If the WEBSOCKET connection is closed, open it."
568 (unless (and (websocket-conn websocket)
569 (ecase (process-status (websocket-conn websocket))
570 ((run open listen) t)
571 ((stop exit signal closed connect failed nil) nil)))
572 (websocket-close websocket)
573 (websocket-open (websocket-url websocket)
574 :protocols (websocket-protocols websocket)
575 :extensions (websocket-extensions websocket)
576 :on-open (websocket-on-open websocket)
577 :on-message (websocket-on-message websocket)
578 :on-close (websocket-on-close websocket)
579 :on-error (websocket-on-error websocket))))
581 ;;;;;;;;;;;;;;;;;;;;;;
582 ;; Websocket client ;;
583 ;;;;;;;;;;;;;;;;;;;;;;
585 (defun* websocket-open (url &key protocols extensions (on-open 'identity)
586 (on-message (lambda (_w _f))) (on-close 'identity)
587 (on-error 'websocket-default-error-handler))
588 "Open a websocket connection to URL, returning the `websocket' struct.
589 The PROTOCOL argument is optional, and setting it will declare to
590 the server that this client supports the protocols in the list
591 given. We will require that the server also has to support that
594 Similar logic applies to EXTENSIONS, which is a list of conses,
595 the car of which is a string naming the extension, and the cdr of
596 which is the list of parameter strings to use for that extension.
597 The parameter strings are of the form \"key=value\" or \"value\".
598 EXTENSIONS can be NIL if none are in use. An example value would
599 be '(\"deflate-stream\" . (\"mux\" \"max-channels=4\")).
601 Optionally you can specify
602 ON-OPEN, ON-MESSAGE and ON-CLOSE callbacks as well.
604 The ON-OPEN callback is called after the connection is
605 established with the websocket as the only argument. The return
608 The ON-MESSAGE callback is called after receiving a frame, and is
609 called with the websocket as the first argument and
610 `websocket-frame' struct as the second. The return value is
613 The ON-CLOSE callback is called after the connection is closed, or
614 failed to open. It is called with the websocket as the only
615 argument, and the return value is unused.
617 The ON-ERROR callback is called when any of the other callbacks
618 have an error. It takes the websocket as the first argument, and
619 a symbol as the second argument either `on-open', `on-message',
620 or `on-close', and the error as the third argument. Do NOT
621 rethrow the error, or else you may miss some websocket messages.
622 You similarly must not generate any other errors in this method.
623 If you want to debug errors, set
624 `websocket-callback-debug-on-error' to `t', but this also can be
625 dangerous is the debugger is quit out of. If not specified,
626 `websocket-default-error-handler' is used.
628 For each of these event handlers, the client code can store
629 arbitrary data in the `client-data' slot in the returned
632 The following errors might be thrown in this method or in
633 websocket processing, all of them having the error-condition
634 `websocket-error' in addition to their own symbol:
636 `websocket-unsupported-protocol': Data in the error signal is the
637 protocol that is unsupported. For example, giving a URL starting
638 with http by mistake raises this error.
640 `websocket-wss-needs-emacs-24': Trying to connect wss protocol
641 using Emacs < 24 raises this error. You can catch this error
642 also by `websocket-unsupported-protocol'.
644 `websocket-received-error-http-response': Data in the error
645 signal is the integer error number.
647 `websocket-invalid-header': Data in the error is a string
648 describing the invalid header received from the server.
650 `websocket-unparseable-frame': Data in the error is a string
651 describing the problem with the frame.
653 (let* ((name (format "websocket to %s" url))
654 (url-struct (url-generic-parse-url url))
655 (key (websocket-genkey))
656 (buf-name (format " *%s*" name))
657 (coding-system-for-read 'binary)
658 (coding-system-for-write 'binary)
659 (conn (if (member (url-type url-struct) '("ws" "wss"))
660 (let* ((type (if (equal (url-type url-struct) "ws")
662 (port (if (= 0 (url-port url-struct))
663 (if (eq type 'tls) 443 80)
664 (url-port url-struct)))
665 (host (url-host url-struct))
666 (buf (get-buffer-create buf-name)))
668 (make-network-process :name name :buffer buf :host host
669 :service port :nowait nil)
670 (condition-case-unless-debug nil
671 (open-network-stream name buf host port :type type :nowait nil)
672 (wrong-number-of-arguments
673 (signal 'websocket-wss-needs-emacs-24 "wss")))))
674 (signal 'websocket-unsupported-protocol (url-type url-struct))))
675 (websocket (websocket-inner-create
679 :on-message on-message
683 :extensions (mapcar 'car extensions)
685 (websocket-calculate-accept key))))
686 (process-put conn :websocket websocket)
687 (set-process-filter conn
688 (lambda (process output)
689 (let ((websocket (process-get process :websocket)))
690 (websocket-outer-filter websocket output))))
691 (set-process-sentinel
693 (lambda (process change)
694 (let ((websocket (process-get process :websocket)))
695 (websocket-debug websocket
696 "State change to %s" change)
697 (unless (eq 'closed (websocket-ready-state websocket))
698 (websocket-try-callback 'websocket-on-close 'on-close websocket)))))
699 (set-process-query-on-exit-flag conn nil)
700 (process-send-string conn
701 (format "GET %s HTTP/1.1\r\n"
702 (let ((path (url-filename url-struct)))
703 (if (> (length path) 0) path "/"))))
704 (websocket-debug websocket "Sending handshake, key: %s, acceptance: %s"
705 key (websocket-accept-string websocket))
706 (process-send-string conn
707 (websocket-create-headers url key protocols extensions))
708 (websocket-debug websocket "Websocket opened")
711 (defun websocket-outer-filter (websocket output)
712 "Filter the WEBSOCKET server's OUTPUT.
713 This will parse headers and process frames repeatedly until there
714 is no more output or the connection closes. If the websocket
715 connection is invalid, the connection will be closed."
716 (websocket-debug websocket "Received: %s" output)
718 (text (concat (websocket-inflight-input websocket) output))
720 (setf (websocket-inflight-input websocket) nil)
721 ;; If we've received the complete header, check to see if we've
722 ;; received the desired handshake.
723 (when (and (eq 'connecting (websocket-ready-state websocket))
724 (setq header-end-pos (string-match "\r\n\r\n" text))
725 (setq start-point (+ 4 header-end-pos)))
728 (websocket-verify-response-code text)
729 (websocket-verify-headers websocket text))
731 (websocket-close websocket)
732 (signal (car err) (cdr err))))
733 (setf (websocket-ready-state websocket) 'open)
734 (websocket-try-callback 'websocket-on-open 'on-open websocket))
735 (when (eq 'open (websocket-ready-state websocket))
736 (websocket-process-input-on-open-ws
737 websocket (substring text (or start-point 0))))))
739 (defun websocket-verify-headers (websocket output)
740 "Based on WEBSOCKET's data, ensure the headers in OUTPUT are valid.
741 The output is assumed to have complete headers. This function
742 will either return t or call `error'. This has the side-effect
743 of populating the list of server extensions to WEBSOCKET."
745 (concat "Sec-WebSocket-Accept: " (websocket-accept-string websocket))))
746 (websocket-debug websocket "Checking for accept header: %s" accept-string)
747 (unless (string-match (regexp-quote accept-string) output)
748 (signal 'websocket-invalid-header
749 "Incorrect handshake from websocket: is this really a websocket connection?")))
750 (let ((case-fold-search t))
751 (websocket-debug websocket "Checking for upgrade header")
752 (unless (string-match "\r\nUpgrade: websocket\r\n" output)
753 (signal 'websocket-invalid-header
754 "No 'Upgrade: websocket' header found"))
755 (websocket-debug websocket "Checking for connection header")
756 (unless (string-match "\r\nConnection: upgrade\r\n" output)
757 (signal 'websocket-invalid-header
758 "No 'Connection: upgrade' header found"))
759 (when (websocket-protocols websocket)
760 (dolist (protocol (websocket-protocols websocket))
761 (websocket-debug websocket "Checking for protocol match: %s"
764 (if (string-match (format "\r\nSec-Websocket-Protocol: %s\r\n"
768 (signal 'websocket-invalid-header
769 "Incorrect or missing protocol returned by the server."))))
770 (setf (websocket-negotiated-protocols websocket) protocols))))
771 (let* ((extensions (websocket-parse-repeated-field
773 "Sec-WebSocket-Extensions"))
775 (dolist (ext extensions)
776 (let ((x (first (split-string ext "; ?"))))
777 (unless (or (member x (websocket-extensions websocket))
778 (member x extra-extensions))
779 (push x extra-extensions))))
780 (when extra-extensions
781 (signal 'websocket-invalid-header
782 (format "Non-requested extensions returned by server: %S"
784 (setf (websocket-negotiated-extensions websocket) extensions)))
787 ;;;;;;;;;;;;;;;;;;;;;;
788 ;; Websocket server ;;
789 ;;;;;;;;;;;;;;;;;;;;;;
791 (defvar websocket-server-websockets nil
792 "A list of current websockets live on any server.")
794 (defun* websocket-server (port &rest plist)
795 "Open a websocket server on PORT.
796 This also takes a plist of callbacks: `:on-open', `:on-message',
797 `:on-close' and `:on-error', which operate exactly as documented
798 in the websocket client function `websocket-open'. Returns the
799 connection, which should be kept in order to pass to
800 `websocket-server-close'."
801 (let* ((conn (make-network-process
802 :name (format "websocket server on port %d" port)
805 :log 'websocket-server-accept
806 :filter-multibyte nil
811 (defun websocket-server-close (conn)
812 "Closes the websocket, as well as all open websockets for this server."
814 (dolist (ws websocket-server-websockets)
815 (when (eq (websocket-server-conn ws) conn)
816 (if (eq (websocket-ready-state ws) 'closed)
817 (unless (member ws to-delete)
819 (websocket-close ws))))
820 (dolist (ws to-delete)
821 (setq websocket-server-websockets (remove ws websocket-server-websockets))))
822 (delete-process conn))
824 (defun websocket-server-accept (server client message)
825 "Accept a new websocket connection from a client."
826 (let ((ws (websocket-inner-create
830 :on-open (or (process-get server :on-open) 'identity)
831 :on-message (or (process-get server :on-message) (lambda (_ws _frame)))
832 :on-close (lexical-let ((user-method
833 (or (process-get server :on-close) 'identity)))
835 (setq websocket-server-websockets
836 (remove ws websocket-server-websockets))
837 (funcall user-method ws)))
838 :on-error (or (process-get server :on-error)
839 'websocket-default-error-handler)
840 :protocols (process-get server :protocol)
841 :extensions (mapcar 'car (process-get server :extensions)))))
842 (unless (member ws websocket-server-websockets)
843 (push ws websocket-server-websockets))
844 (set-process-coding-system client 'unix 'unix)
845 (process-put client :websocket ws)
846 (set-process-filter client 'websocket-server-filter)
847 (set-process-coding-system client 'binary)
848 (set-process-sentinel client
849 (lambda (process change)
850 (let ((websocket (process-get process :websocket)))
851 (websocket-debug websocket "State change to %s" change)
852 (unless (eq 'closed (websocket-ready-state websocket))
853 (websocket-try-callback 'websocket-on-close 'on-close websocket)))))))
855 (defun websocket-create-headers (url key protocol extensions)
856 "Create connections headers for the given URL, KEY, PROTOCOL and EXTENSIONS.
857 These are defined as in `websocket-open'."
858 (format (concat "Host: %s\r\n"
859 "Upgrade: websocket\r\n"
860 "Connection: Upgrade\r\n"
861 "Sec-WebSocket-Key: %s\r\n"
863 "Sec-WebSocket-Version: 13\r\n"
866 (mapconcat (lambda (protocol)
867 (format "Sec-WebSocket-Protocol: %s" protocol))
871 (format "Sec-WebSocket-Extensions: %s\r\n"
875 (when (cdr ext) "; ")
877 (mapconcat 'identity (cdr ext) "; "))))
880 (url-host (url-generic-parse-url url))
885 (defun websocket-get-server-response (websocket client-protocols client-extensions)
886 "Get the websocket response from client WEBSOCKET."
887 (let ((separator "\r\n"))
888 (concat "HTTP/1.1 101 Switching Protocols" separator
889 "Upgrade: websocket" separator
890 "Connection: Upgrade" separator
891 "Sec-WebSocket-Accept: "
892 (websocket-accept-string websocket) separator
894 (websocket-intersect client-protocols
895 (websocket-protocols websocket))))
899 (lambda (protocol) (format "Sec-WebSocket-Protocol: %s"
900 protocol)) protocols separator)
902 (let ((extensions (websocket-intersect
904 (websocket-extensions websocket))))
908 (lambda (extension) (format "Sec-Websocket-Extensions: %s"
909 extension)) extensions separator)
913 (defun websocket-server-filter (process output)
914 "This acts on all OUTPUT from websocket clients PROCESS."
915 (let* ((ws (process-get process :websocket))
916 (text (concat (websocket-inflight-input ws) output)))
917 (setf (websocket-inflight-input ws) nil)
918 (cond ((eq (websocket-ready-state ws) 'connecting)
919 ;; check for connection string
920 (let ((end-of-header-pos
921 (let ((pos (string-match "\r\n\r\n" text)))
922 (when pos (+ 4 pos)))))
923 (if end-of-header-pos
925 (let ((header-info (websocket-verify-client-headers text)))
927 (progn (setf (websocket-accept-string ws)
928 (websocket-calculate-accept
929 (plist-get header-info :key)))
932 (websocket-get-server-response
933 ws (plist-get header-info :protocols)
934 (plist-get header-info :extensions)))
935 (setf (websocket-ready-state ws) 'open)
936 (websocket-try-callback 'websocket-on-open
938 (message "Invalid client headers found in: %s" output)
939 (process-send-string process "HTTP/1.1 400 Bad Request\r\n\r\n")
940 (websocket-close ws)))
941 (when (> (length text) (+ 1 end-of-header-pos))
942 (websocket-server-filter process (substring
944 end-of-header-pos))))
945 (setf (websocket-inflight-input ws) text))))
946 ((eq (websocket-ready-state ws) 'open)
947 (websocket-process-input-on-open-ws ws text))
948 ((eq (websocket-ready-state ws) 'closed)
949 (message "WARNING: Should not have received further input on closed websocket")))))
951 (defun websocket-verify-client-headers (output)
952 "Verify the headers from the WEBSOCKET client connection in OUTPUT.
953 Unlike `websocket-verify-headers', this is a quieter routine. We
954 don't want to error due to a bad client, so we just print out
955 messages and a plist containing `:key', the websocket key,
956 `:protocols' and `:extensions'."
958 (let ((case-fold-search t)
960 (unless (string-match "HTTP/1.1" output)
961 (message "Websocket client connection: HTTP/1.1 not found")
963 (unless (string-match "^Host: " output)
964 (message "Websocket client connection: Host header not found")
966 (unless (string-match "^Upgrade: websocket\r\n" output)
967 (message "Websocket client connection: Upgrade: websocket not found")
969 (if (string-match "^Sec-WebSocket-Key: \\([[:graph:]]+\\)\r\n" output)
970 (setq plist (plist-put plist :key (match-string 1 output)))
971 (message "Websocket client connect: No key sent")
973 (unless (string-match "^Sec-WebSocket-Version: 13" output)
974 (message "Websocket client connect: Websocket version 13 not found")
976 (when (string-match "^Sec-WebSocket-Protocol:" output)
977 (setq plist (plist-put plist :protocols (websocket-parse-repeated-field
979 "Sec-Websocket-Protocol"))))
980 (when (string-match "^Sec-WebSocket-Extensions:" output)
981 (setq plist (plist-put plist :extensions (websocket-parse-repeated-field
983 "Sec-Websocket-Extensions"))))
988 ;;; websocket.el ends here