1 ;;; websocket.el --- Emacs WebSocket client and server
3 ;; Copyright (c) 2013, 2016 Free Software Foundation, Inc.
5 ;; Author: Andrew Hyatt <ahyatt@gmail.com>
6 ;; Keywords: Communication, Websocket, Server
9 ;; This program is free software; you can redistribute it and/or
10 ;; modify it under the terms of the GNU General Public License as
11 ;; published by the Free Software Foundation; either version 3 of the
12 ;; License, or (at your option) any later version.
14 ;; This program is distributed in the hope that it will be useful, but
15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 ;; General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23 ;; This implements RFC 6455, which can be found at
24 ;; http://tools.ietf.org/html/rfc6455.
26 ;; This library contains code to connect Emacs as a client to a
27 ;; websocket server, and for Emacs to act as a server for websocket
30 ;; Websockets clients are created by calling `websocket-open', which
31 ;; returns a `websocket' struct. Users of this library use the
32 ;; websocket struct, and can call methods `websocket-send-text', which
33 ;; sends text over the websocket, or `websocket-send', which sends a
34 ;; `websocket-frame' struct, enabling finer control of what is sent.
35 ;; A callback is passed to `websocket-open' that will retrieve
36 ;; websocket frames called from the websocket. Websockets are
37 ;; eventually closed with `websocket-close'.
39 ;; Server functionality is similar. A server is started with
40 ;; `websocket-server' called with a port and the callbacks to use,
41 ;; which returns a process. The process can later be closed with
42 ;; `websocket-server-close'. A `websocket' struct is also created
43 ;; 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.5"
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-callback-debug-on-error nil
115 "If true, when an error happens in a client callback, invoke the debugger.
116 Having this on can cause issues with missing frames if the debugger is
117 exited by quitting instead of continuing, so it's best to have this set
118 to nil unless it is especially needed.")
120 (defmacro websocket-document-function (function docstring)
121 "Document FUNCTION with DOCSTRING. Use this for defstruct accessor etc."
122 (declare (indent defun)
124 `(put ',function 'function-documentation ,docstring))
126 (websocket-document-function websocket-on-open
127 "Accessor for websocket on-open callback.
128 See `websocket-open' for details.
132 (websocket-document-function websocket-on-message
133 "Accessor for websocket on-message callback.
134 See `websocket-open' for details.
138 (websocket-document-function websocket-on-close
139 "Accessor for websocket on-close callback.
140 See `websocket-open' for details.
144 (websocket-document-function websocket-on-error
145 "Accessor for websocket on-error callback.
146 See `websocket-open' for details.
150 (defun websocket-genbytes (nbytes)
151 "Generate NBYTES random bytes."
152 (let ((s (make-string nbytes ?\s)))
154 (aset s i (random 256)))
157 (defun websocket-try-callback (websocket-callback callback-type websocket
159 "Invoke function WEBSOCKET-CALLBACK with WEBSOCKET and REST args.
160 If an error happens, it is handled according to
161 `websocket-callback-debug-on-error'."
162 ;; This looks like it should be able to done more efficiently, but
163 ;; I'm not sure that's the case. We can't do it as a macro, since
164 ;; we want it to change whenever websocket-callback-debug-on-error
167 (debug-on-error websocket-callback-debug-on-error))
168 (push websocket args)
169 (if websocket-callback-debug-on-error
171 (apply (funcall websocket-callback websocket) args)
172 ((debug error) (funcall (websocket-on-error websocket)
173 websocket callback-type err)))
175 (apply (funcall websocket-callback websocket) args)
176 (error (funcall (websocket-on-error websocket) websocket
177 callback-type err))))))
179 (defun websocket-genkey ()
180 "Generate a key suitable for the websocket handshake."
181 (base64-encode-string (websocket-genbytes 16)))
183 (defun websocket-calculate-accept (key)
184 "Calculate the expect value of the accept header.
185 This is based on the KEY from the Sec-WebSocket-Key header."
186 (base64-encode-string
187 (sha1 (concat key websocket-guid) nil nil t)))
189 (defun websocket-get-bytes (s n)
190 "From string S, retrieve the value of N bytes.
191 Return the value as an unsigned integer. The value N must be a
194 We support getting frames up to 536870911 bytes (2^29 - 1),
195 approximately 537M long."
198 (bindat-get-field (bindat-unpack '((:val vec 2 u32)) s) :val))
200 (logior (lsh (aref 32-bit-parts 0) 32) (aref 32-bit-parts 1))))
201 (if (and (= (aref 32-bit-parts 0) 0)
202 (= (lsh (aref 32-bit-parts 1) -29) 0))
204 (signal 'websocket-unparseable-frame
205 "Frame value found too large to parse!")))
214 ;; This is an error with the library,
215 ;; not a user-facing, meaningful error.
217 "websocket-get-bytes: Unknown N: %s" n)))))
219 (args-out-of-range (signal 'websocket-unparseable-frame
220 (format "Frame unexpectedly shortly: %s" s))))
223 (defun websocket-to-bytes (val nbytes)
224 "Encode the integer VAL in NBYTES of data.
225 NBYTES much be a power of 2, up to 8.
227 This supports encoding values up to 536870911 bytes (2^29 - 1),
228 approximately 537M long."
229 (when (and (< nbytes 8)
230 (> val (expt 2 (* 8 nbytes))))
231 ;; not a user-facing error, this must be caused from an error in
233 (error "websocket-to-bytes: Value %d could not be expressed in %d bytes"
237 (let ((hi-32bits (lsh val -32))
238 ;; Test for systems that don't have > 32 bits, and
239 ;; for those systems just return the value.
240 (low-32bits (if (= 0 (expt 2 32))
242 (logand #xffffffff val))))
243 (when (or (> hi-32bits 0) (> (lsh low-32bits -29) 0))
244 (signal 'websocket-frame-too-large val))
245 (bindat-pack `((:val vec 2 u32))
246 `((:val . [,hi-32bits ,low-32bits])))))
248 `((:val ,(cond ((= nbytes 1) 'u8)
251 ;; Library error, not system error
252 (t (error "websocket-to-bytes: Unknown NBYTES: %s" nbytes)))))
255 (defun websocket-get-opcode (s)
256 "Retrieve the opcode from first byte of string S."
257 (websocket-ensure-length s 1)
258 (let ((opcode (logand #xf (websocket-get-bytes s 1))))
259 (cond ((= opcode 0) 'continuation)
261 ((= opcode 2) 'binary)
262 ((= opcode 8) 'close)
264 ((= opcode 10) 'pong))))
266 (defun websocket-get-payload-len (s)
267 "Parse out the payload length from the string S.
268 We start at position 0, and return a cons of the payload length and how
269 many bytes were consumed from the string."
270 (websocket-ensure-length s 1)
271 (let* ((initial-val (logand 127 (websocket-get-bytes s 1))))
272 (cond ((= initial-val 127)
273 (websocket-ensure-length s 9)
274 (cons (websocket-get-bytes (substring s 1) 8) 9))
276 (websocket-ensure-length s 3)
277 (cons (websocket-get-bytes (substring s 1) 2) 3))
278 (t (cons initial-val 1)))))
280 (defstruct websocket-frame opcode payload length completep)
282 (defun websocket-mask (key data)
283 "Using string KEY, mask string DATA according to the RFC.
284 This is used to both mask and unmask data."
287 (loop for b across data
288 for i from 0 to (length data)
289 collect (logxor (websocket-get-bytes (substring key (mod i 4)) 1) b))))
291 (defun websocket-ensure-length (s n)
292 "Ensure the string S has at most N bytes.
293 Otherwise we throw the error `websocket-incomplete-frame'."
294 (when (< (length s) n)
295 (throw 'websocket-incomplete-frame nil)))
297 (defun websocket-encode-frame (frame should-mask)
298 "Encode the FRAME struct to the binary representation.
299 We mask the frame or not, depending on SHOULD-MASK."
300 (let* ((opcode (websocket-frame-opcode frame))
301 (payload (websocket-frame-payload frame))
302 (fin (websocket-frame-completep frame))
303 (payloadp (and payload
304 (memq opcode '(continuation ping pong text binary))))
305 (mask-key (when should-mask (websocket-genbytes 4))))
306 (apply 'unibyte-string
307 (let ((val (append (list
308 (logior (cond ((eq opcode 'continuation) 0)
309 ((eq opcode 'text) 1)
310 ((eq opcode 'binary) 2)
311 ((eq opcode 'close) 8)
312 ((eq opcode 'ping) 9)
313 ((eq opcode 'pong) 10))
318 (if should-mask 128 0)
319 (cond ((< (length payload) 126) (length payload))
320 ((< (length payload) 65536) 126)
322 (when (and payloadp (>= (length payload) 126))
323 (append (websocket-to-bytes
325 (cond ((< (length payload) 126) 1)
326 ((< (length payload) 65536) 2)
328 (when (and payloadp should-mask)
329 (append mask-key nil))
331 (append (if should-mask (websocket-mask mask-key payload)
334 ;; We have to make sure the non-payload data is a full 32-bit frame
335 (if (= 1 (length val))
336 (append val '(0)) val)))))
338 (defun websocket-read-frame (s)
339 "Read from string S a `websocket-frame' struct with the contents.
340 This only gets complete frames. Partial frames need to wait until
341 the frame finishes. If the frame is not completed, return NIL."
342 (catch 'websocket-incomplete-frame
343 (websocket-ensure-length s 1)
344 (let* ((opcode (websocket-get-opcode s))
345 (fin (logand 128 (websocket-get-bytes s 1)))
346 (payloadp (memq opcode '(continuation text binary ping pong)))
347 (payload-len (when payloadp
348 (websocket-get-payload-len (substring s 1))))
351 (= 128 (logand 128 (websocket-get-bytes (substring s 1) 1)))))
352 (payload-start (when payloadp (+ (if maskp 5 1) (cdr payload-len))))
353 (payload-end (when payloadp (+ payload-start (car payload-len))))
354 (unmasked-payload (when payloadp
355 (websocket-ensure-length s payload-end)
356 (substring s payload-start payload-end))))
357 (make-websocket-frame
361 (let ((masking-key (substring s (+ 1 (cdr payload-len))
362 (+ 5 (cdr payload-len)))))
363 (websocket-mask masking-key unmasked-payload))
365 :length (if payloadp payload-end 1)
366 :completep (> fin 0)))))
368 (defun websocket-format-error (err)
369 "Format an error message like command level does.
370 ERR should be a cons of error symbol and error data."
372 ;; Formatting code adapted from `edebug-report-error'
373 (concat (or (get (car err) 'error-message)
374 (format "peculiar error (%s)" (car err)))
377 (mapconcat #'prin1-to-string
380 (defun websocket-default-error-handler (_websocket type err)
381 "The default error handler used to handle errors in callbacks."
382 (display-warning 'websocket
383 (format "in callback `%S': %s"
385 (websocket-format-error err))
388 ;; Error symbols in use by the library
389 (put 'websocket-unsupported-protocol 'error-conditions
390 '(error websocket-error websocket-unsupported-protocol))
391 (put 'websocket-unsupported-protocol 'error-message "Unsupported websocket protocol")
392 (put 'websocket-wss-needs-emacs-24 'error-conditions
393 '(error websocket-error websocket-unsupported-protocol
394 websocket-wss-needs-emacs-24))
395 (put 'websocket-wss-needs-emacs-24 'error-message
396 "wss protocol is not supported for Emacs before version 24.")
397 (put 'websocket-received-error-http-response 'error-conditions
398 '(error websocket-error websocket-received-error-http-response))
399 (put 'websocket-received-error-http-response 'error-message
400 "Error response received from websocket server")
401 (put 'websocket-invalid-header 'error-conditions
402 '(error websocket-error websocket-invalid-header))
403 (put 'websocket-invalid-header 'error-message
404 "Invalid HTTP header sent")
405 (put 'websocket-illegal-frame 'error-conditions
406 '(error websocket-error websocket-illegal-frame))
407 (put 'websocket-illegal-frame 'error-message
408 "Cannot send illegal frame to websocket")
409 (put 'websocket-closed 'error-conditions
410 '(error websocket-error websocket-closed))
411 (put 'websocket-closed 'error-message
412 "Cannot send message to a closed websocket")
413 (put 'websocket-unparseable-frame 'error-conditions
414 '(error websocket-error websocket-unparseable-frame))
415 (put 'websocket-unparseable-frame 'error-message
416 "Received an unparseable frame")
417 (put 'websocket-frame-too-large 'error-conditions
418 '(error websocket-error websocket-frame-too-large))
419 (put 'websocket-frame-too-large 'error-message
420 "The frame being sent is too large for this emacs to handle")
422 (defun websocket-intersect (a b)
423 "Simple list intersection, should function like Common Lisp's `intersection'."
425 (dolist (elem a (nreverse result))
426 (when (member elem b)
427 (push elem result)))))
429 (defun websocket-get-debug-buffer-create (websocket)
430 "Get or create the buffer corresponding to WEBSOCKET."
431 (let ((buf (get-buffer-create (format "*websocket %s debug*"
432 (websocket-url websocket)))))
433 (when (= 0 (buffer-size buf))
434 (buffer-disable-undo buf))
437 (defun websocket-debug (websocket msg &rest args)
438 "In the WEBSOCKET's debug buffer, send MSG, with format ARGS."
439 (when websocket-debug
440 (let ((buf (websocket-get-debug-buffer-create websocket)))
442 (with-current-buffer buf
443 (goto-char (point-max))
445 (insert (apply 'format (append (list msg) args)))
448 (defun websocket-verify-response-code (output)
449 "Verify that OUTPUT contains a valid HTTP response code.
450 The only acceptable one to websocket is responce code 101.
451 A t value will be returned on success, and an error thrown
453 (string-match "HTTP/1.1 \\([[:digit:]]+\\)" output)
454 (unless (equal "101" (match-string 1 output))
455 (signal 'websocket-received-error-http-response
456 (string-to-number (match-string 1 output))))
459 (defun websocket-parse-repeated-field (output field)
460 "From header-containing OUTPUT, parse out the list from a
461 possibly repeated field."
465 (string-match (format "\r\n%s: \\(.*\\)\r\n" field)
467 (when (setq pos (match-end 1))
468 (setq extensions (append extensions (split-string
469 (match-string 1 output) ", ?")))))
472 (defun websocket-process-frame (websocket frame)
473 "Using the WEBSOCKET's filter and connection, process the FRAME.
474 This returns a lambda that should be executed when all frames have
475 been processed. If the frame has a payload, the lambda has the frame
476 passed to the filter slot of WEBSOCKET. If the frame is a ping,
477 the lambda has a reply with a pong. If the frame is a close, the lambda
478 has connection termination."
479 (let ((opcode (websocket-frame-opcode frame)))
480 (lexical-let ((lex-ws websocket)
482 (cond ((memq opcode '(continuation text binary))
483 (lambda () (websocket-try-callback 'websocket-on-message 'on-message
486 (lambda () (websocket-send lex-ws
487 (make-websocket-frame
489 :payload (websocket-frame-payload lex-frame)
492 (lambda () (delete-process (websocket-conn lex-ws))))
495 (defun websocket-process-input-on-open-ws (websocket text)
496 "This handles input processing for both the client and server filters."
497 (let ((current-frame)
500 (while (setq current-frame (websocket-read-frame
501 (substring text start-point)))
502 (push (websocket-process-frame websocket current-frame) processing-queue)
503 (incf start-point (websocket-frame-length current-frame)))
504 (when (> (length text) start-point)
505 (setf (websocket-inflight-input websocket)
506 (substring text start-point)))
507 (dolist (to-process (nreverse processing-queue))
508 (funcall to-process))))
510 (defun websocket-send-text (websocket text)
511 "To the WEBSOCKET, send TEXT as a complete frame."
514 (make-websocket-frame :opcode 'text
515 :payload (encode-coding-string
519 (defun websocket-check (frame)
520 "Check FRAME for correctness, returning true if correct."
522 ;; Text, binary, and continuation frames need payloads
523 (and (memq (websocket-frame-opcode frame) '(text binary continuation))
524 (websocket-frame-payload frame))
525 ;; Pings and pongs may optionally have them
526 (memq (websocket-frame-opcode frame) '(ping pong))
527 ;; And close shouldn't have any payload, and should always be complete.
528 (and (eq (websocket-frame-opcode frame) 'close)
529 (not (websocket-frame-payload frame))
530 (websocket-frame-completep frame))))
532 (defun websocket-send (websocket frame)
533 "To the WEBSOCKET server, send the FRAME.
534 This will raise an error if the frame is illegal.
536 The error signaled may be of type `websocket-illegal-frame' if
537 the frame is malformed in some way, also having the condition
538 type of `websocket-error'. The data associated with the signal
539 is the frame being sent.
541 If the websocket is closed a signal `websocket-closed' is sent,
542 also with `websocket-error' condition. The data in the signal is
545 The frame may be too large for this buid of Emacs, in which case
546 `websocket-frame-too-large' is returned, with the data of the
547 size of the frame which was too large to process. This also has
548 the `websocket-error' condition."
549 (unless (websocket-check frame)
550 (signal 'websocket-illegal-frame frame))
551 (websocket-debug websocket "Sending frame, opcode: %s payload: %s"
552 (websocket-frame-opcode frame)
553 (websocket-frame-payload frame))
554 (websocket-ensure-connected websocket)
555 (unless (websocket-openp websocket)
556 (signal 'websocket-closed frame))
557 (process-send-string (websocket-conn websocket)
558 ;; We mask only when we're a client, following the spec.
559 (websocket-encode-frame frame (not (websocket-server-p websocket)))))
561 (defun websocket-openp (websocket)
562 "Check WEBSOCKET and return non-nil if it is open, and either
565 (not (eq 'close (websocket-ready-state websocket)))
566 (member (process-status (websocket-conn websocket)) '(open run))))
568 (defun websocket-close (websocket)
569 "Close WEBSOCKET and erase all the old websocket data."
570 (websocket-debug websocket "Closing websocket")
571 (websocket-try-callback 'websocket-on-close 'on-close websocket)
572 (when (websocket-openp websocket)
573 (websocket-send websocket
574 (make-websocket-frame :opcode 'close
576 (setf (websocket-ready-state websocket) 'closed))
577 (delete-process (websocket-conn websocket)))
579 (defun websocket-ensure-connected (websocket)
580 "If the WEBSOCKET connection is closed, open it."
581 (unless (and (websocket-conn websocket)
582 (ecase (process-status (websocket-conn websocket))
583 ((run open listen) t)
584 ((stop exit signal closed connect failed nil) nil)))
585 (websocket-close websocket)
586 (websocket-open (websocket-url websocket)
587 :protocols (websocket-protocols websocket)
588 :extensions (websocket-extensions websocket)
589 :on-open (websocket-on-open websocket)
590 :on-message (websocket-on-message websocket)
591 :on-close (websocket-on-close websocket)
592 :on-error (websocket-on-error websocket))))
594 ;;;;;;;;;;;;;;;;;;;;;;
595 ;; Websocket client ;;
596 ;;;;;;;;;;;;;;;;;;;;;;
598 (defun* websocket-open (url &key protocols extensions (on-open 'identity)
599 (on-message (lambda (_w _f))) (on-close 'identity)
600 (on-error 'websocket-default-error-handler))
601 "Open a websocket connection to URL, returning the `websocket' struct.
602 The PROTOCOL argument is optional, and setting it will declare to
603 the server that this client supports the protocols in the list
604 given. We will require that the server also has to support that
607 Similar logic applies to EXTENSIONS, which is a list of conses,
608 the car of which is a string naming the extension, and the cdr of
609 which is the list of parameter strings to use for that extension.
610 The parameter strings are of the form \"key=value\" or \"value\".
611 EXTENSIONS can be NIL if none are in use. An example value would
612 be '(\"deflate-stream\" . (\"mux\" \"max-channels=4\")).
614 Cookies that are set via `url-cookie-store' will be used during
615 communication with the server, and cookies received from the
616 server will be stored in the same cookie storage that the
617 `url-cookie' package uses.
619 Optionally you can specify
620 ON-OPEN, ON-MESSAGE and ON-CLOSE callbacks as well.
622 The ON-OPEN callback is called after the connection is
623 established with the websocket as the only argument. The return
626 The ON-MESSAGE callback is called after receiving a frame, and is
627 called with the websocket as the first argument and
628 `websocket-frame' struct as the second. The return value is
631 The ON-CLOSE callback is called after the connection is closed, or
632 failed to open. It is called with the websocket as the only
633 argument, and the return value is unused.
635 The ON-ERROR callback is called when any of the other callbacks
636 have an error. It takes the websocket as the first argument, and
637 a symbol as the second argument either `on-open', `on-message',
638 or `on-close', and the error as the third argument. Do NOT
639 rethrow the error, or else you may miss some websocket messages.
640 You similarly must not generate any other errors in this method.
641 If you want to debug errors, set
642 `websocket-callback-debug-on-error' to `t', but this also can be
643 dangerous is the debugger is quit out of. If not specified,
644 `websocket-default-error-handler' is used.
646 For each of these event handlers, the client code can store
647 arbitrary data in the `client-data' slot in the returned
650 The following errors might be thrown in this method or in
651 websocket processing, all of them having the error-condition
652 `websocket-error' in addition to their own symbol:
654 `websocket-unsupported-protocol': Data in the error signal is the
655 protocol that is unsupported. For example, giving a URL starting
656 with http by mistake raises this error.
658 `websocket-wss-needs-emacs-24': Trying to connect wss protocol
659 using Emacs < 24 raises this error. You can catch this error
660 also by `websocket-unsupported-protocol'.
662 `websocket-received-error-http-response': Data in the error
663 signal is the integer error number.
665 `websocket-invalid-header': Data in the error is a string
666 describing the invalid header received from the server.
668 `websocket-unparseable-frame': Data in the error is a string
669 describing the problem with the frame.
671 (let* ((name (format "websocket to %s" url))
672 (url-struct (url-generic-parse-url url))
673 (key (websocket-genkey))
674 (coding-system-for-read 'binary)
675 (coding-system-for-write 'binary)
676 (conn (if (member (url-type url-struct) '("ws" "wss"))
677 (let* ((type (if (equal (url-type url-struct) "ws")
679 (port (if (= 0 (url-port url-struct))
680 (if (eq type 'tls) 443 80)
681 (url-port url-struct)))
682 (host (url-host url-struct)))
684 (make-network-process :name name :buffer nil :host host
685 :service port :nowait nil)
686 (condition-case-unless-debug nil
687 (open-network-stream name nil host port :type type :nowait nil)
688 (wrong-number-of-arguments
689 (signal 'websocket-wss-needs-emacs-24 "wss")))))
690 (signal 'websocket-unsupported-protocol (url-type url-struct))))
691 (websocket (websocket-inner-create
695 :on-message on-message
699 :extensions (mapcar 'car extensions)
701 (websocket-calculate-accept key))))
702 (unless conn (error "Could not establish the websocket connection to %s" url))
703 (process-put conn :websocket websocket)
704 (set-process-filter conn
705 (lambda (process output)
706 (let ((websocket (process-get process :websocket)))
707 (websocket-outer-filter websocket output))))
708 (set-process-sentinel
710 (lambda (process change)
711 (let ((websocket (process-get process :websocket)))
712 (websocket-debug websocket "State change to %s" change)
714 (member (process-status process) '(closed failed exit signal))
715 (not (eq 'closed (websocket-ready-state websocket))))
716 (websocket-try-callback 'websocket-on-close 'on-close websocket)))))
717 (set-process-query-on-exit-flag conn nil)
718 (process-send-string conn
719 (format "GET %s HTTP/1.1\r\n"
720 (let ((path (url-filename url-struct)))
721 (if (> (length path) 0) path "/"))))
722 (websocket-debug websocket "Sending handshake, key: %s, acceptance: %s"
723 key (websocket-accept-string websocket))
724 (process-send-string conn
725 (websocket-create-headers url key protocols extensions))
726 (websocket-debug websocket "Websocket opened")
729 (defun websocket-process-headers (url headers)
730 "On opening URL, process the HEADERS sent from the server."
731 (when (string-match "Set-Cookie: \(.*\)\r\n" headers)
732 ;; The url-current-object is assumed to be set by
733 ;; url-cookie-handle-set-cookie.
734 (let ((url-current-object (url-generic-parse-url url)))
735 (url-cookie-handle-set-cookie (match-string 1 headers)))))
737 (defun websocket-outer-filter (websocket output)
738 "Filter the WEBSOCKET server's OUTPUT.
739 This will parse headers and process frames repeatedly until there
740 is no more output or the connection closes. If the websocket
741 connection is invalid, the connection will be closed."
742 (websocket-debug websocket "Received: %s" output)
744 (text (concat (websocket-inflight-input websocket) output))
746 (setf (websocket-inflight-input websocket) nil)
747 ;; If we've received the complete header, check to see if we've
748 ;; received the desired handshake.
749 (when (and (eq 'connecting (websocket-ready-state websocket))
750 (setq header-end-pos (string-match "\r\n\r\n" text))
751 (setq start-point (+ 4 header-end-pos)))
754 (websocket-verify-response-code text)
755 (websocket-verify-headers websocket text)
756 (websocket-process-headers (websocket-url websocket) text))
758 (websocket-close websocket)
759 (signal (car err) (cdr err))))
760 (setf (websocket-ready-state websocket) 'open)
761 (websocket-try-callback 'websocket-on-open 'on-open websocket))
762 (when (eq 'open (websocket-ready-state websocket))
763 (websocket-process-input-on-open-ws
764 websocket (substring text (or start-point 0))))))
766 (defun websocket-verify-headers (websocket output)
767 "Based on WEBSOCKET's data, ensure the headers in OUTPUT are valid.
768 The output is assumed to have complete headers. This function
769 will either return t or call `error'. This has the side-effect
770 of populating the list of server extensions to WEBSOCKET."
772 (concat "Sec-WebSocket-Accept: " (websocket-accept-string websocket))))
773 (websocket-debug websocket "Checking for accept header: %s" accept-string)
774 (unless (string-match (regexp-quote accept-string) output)
775 (signal 'websocket-invalid-header
776 "Incorrect handshake from websocket: is this really a websocket connection?")))
777 (let ((case-fold-search t))
778 (websocket-debug websocket "Checking for upgrade header")
779 (unless (string-match "\r\nUpgrade: websocket\r\n" output)
780 (signal 'websocket-invalid-header
781 "No 'Upgrade: websocket' header found"))
782 (websocket-debug websocket "Checking for connection header")
783 (unless (string-match "\r\nConnection: upgrade\r\n" output)
784 (signal 'websocket-invalid-header
785 "No 'Connection: upgrade' header found"))
786 (when (websocket-protocols websocket)
787 (dolist (protocol (websocket-protocols websocket))
788 (websocket-debug websocket "Checking for protocol match: %s"
791 (if (string-match (format "\r\nSec-Websocket-Protocol: %s\r\n"
795 (signal 'websocket-invalid-header
796 "Incorrect or missing protocol returned by the server."))))
797 (setf (websocket-negotiated-protocols websocket) protocols))))
798 (let* ((extensions (websocket-parse-repeated-field
800 "Sec-WebSocket-Extensions"))
802 (dolist (ext extensions)
803 (let ((x (first (split-string ext "; ?"))))
804 (unless (or (member x (websocket-extensions websocket))
805 (member x extra-extensions))
806 (push x extra-extensions))))
807 (when extra-extensions
808 (signal 'websocket-invalid-header
809 (format "Non-requested extensions returned by server: %S"
811 (setf (websocket-negotiated-extensions websocket) extensions)))
814 ;;;;;;;;;;;;;;;;;;;;;;
815 ;; Websocket server ;;
816 ;;;;;;;;;;;;;;;;;;;;;;
818 (defvar websocket-server-websockets nil
819 "A list of current websockets live on any server.")
821 (defun* websocket-server (port &rest plist)
822 "Open a websocket server on PORT.
823 This also takes a plist of callbacks: `:on-open', `:on-message',
824 `:on-close' and `:on-error', which operate exactly as documented
825 in the websocket client function `websocket-open'. Returns the
826 connection, which should be kept in order to pass to
827 `websocket-server-close'."
828 (let* ((conn (make-network-process
829 :name (format "websocket server on port %s" port)
832 :filter 'websocket-server-filter
833 :log 'websocket-server-accept
834 :filter-multibyte nil
839 (defun websocket-server-close (conn)
840 "Closes the websocket, as well as all open websockets for this server."
842 (dolist (ws websocket-server-websockets)
843 (when (eq (websocket-server-conn ws) conn)
844 (if (eq (websocket-ready-state ws) 'closed)
845 (unless (member ws to-delete)
847 (websocket-close ws))))
848 (dolist (ws to-delete)
849 (setq websocket-server-websockets (remove ws websocket-server-websockets))))
850 (delete-process conn))
852 (defun websocket-server-accept (server client message)
853 "Accept a new websocket connection from a client."
854 (let ((ws (websocket-inner-create
859 :on-open (or (process-get server :on-open) 'identity)
860 :on-message (or (process-get server :on-message) (lambda (_ws _frame)))
861 :on-close (lexical-let ((user-method
862 (or (process-get server :on-close) 'identity)))
864 (setq websocket-server-websockets
865 (remove ws websocket-server-websockets))
866 (funcall user-method ws)))
867 :on-error (or (process-get server :on-error)
868 'websocket-default-error-handler)
869 :protocols (process-get server :protocol)
870 :extensions (mapcar 'car (process-get server :extensions)))))
871 (unless (member ws websocket-server-websockets)
872 (push ws websocket-server-websockets))
873 (process-put client :websocket ws)
874 (set-process-coding-system client 'binary 'binary)
875 (set-process-sentinel client
876 (lambda (process change)
877 (let ((websocket (process-get process :websocket)))
878 (websocket-debug websocket "State change to %s" change)
880 (member (process-status process) '(closed failed exit signal))
881 (not (eq 'closed (websocket-ready-state websocket))))
882 (websocket-try-callback 'websocket-on-close 'on-close websocket)))))))
884 (defun websocket-create-headers (url key protocol extensions)
885 "Create connections headers for the given URL, KEY, PROTOCOL and EXTENSIONS.
886 These are defined as in `websocket-open'."
887 (let* ((parsed-url (url-generic-parse-url url))
888 (host-port (if (url-port-if-non-default parsed-url)
889 (format "%s:%s" (url-host parsed-url) (url-port parsed-url))
890 (url-host parsed-url)))
891 (cookie-header (url-cookie-generate-header-lines
892 host-port (car (url-path-and-query parsed-url))
893 (equal (url-type parsed-url) "wss"))))
894 (format (concat "Host: %s\r\n"
895 "Upgrade: websocket\r\n"
896 "Connection: Upgrade\r\n"
897 "Sec-WebSocket-Key: %s\r\n"
898 "Sec-WebSocket-Version: 13\r\n"
903 (format "Sec-WebSocket-Protocol: %s" protocol))
907 (format "Sec-WebSocket-Extensions: %s\r\n"
912 (when (cdr ext) "; ")
914 (mapconcat 'identity (cdr ext) "; "))))
916 (when cookie-header cookie-header)
922 (defun websocket-get-server-response (websocket client-protocols client-extensions)
923 "Get the websocket response from client WEBSOCKET."
924 (let ((separator "\r\n"))
925 (concat "HTTP/1.1 101 Switching Protocols" separator
926 "Upgrade: websocket" separator
927 "Connection: Upgrade" separator
928 "Sec-WebSocket-Accept: "
929 (websocket-accept-string websocket) separator
931 (websocket-intersect client-protocols
932 (websocket-protocols websocket))))
936 (lambda (protocol) (format "Sec-WebSocket-Protocol: %s"
937 protocol)) protocols separator)
939 (let ((extensions (websocket-intersect
941 (websocket-extensions websocket))))
945 (lambda (extension) (format "Sec-Websocket-Extensions: %s"
946 extension)) extensions separator)
950 (defun websocket-server-filter (process output)
951 "This acts on all OUTPUT from websocket clients PROCESS."
952 (let* ((ws (process-get process :websocket))
953 (text (concat (websocket-inflight-input ws) output)))
954 (setf (websocket-inflight-input ws) nil)
955 (cond ((eq (websocket-ready-state ws) 'connecting)
956 ;; check for connection string
957 (let ((end-of-header-pos
958 (let ((pos (string-match "\r\n\r\n" text)))
959 (when pos (+ 4 pos)))))
960 (if end-of-header-pos
962 (let ((header-info (websocket-verify-client-headers text)))
964 (progn (setf (websocket-accept-string ws)
965 (websocket-calculate-accept
966 (plist-get header-info :key)))
969 (websocket-get-server-response
970 ws (plist-get header-info :protocols)
971 (plist-get header-info :extensions)))
972 (setf (websocket-ready-state ws) 'open)
973 (websocket-try-callback 'websocket-on-open
975 (message "Invalid client headers found in: %s" output)
976 (process-send-string process "HTTP/1.1 400 Bad Request\r\n\r\n")
977 (websocket-close ws)))
978 (when (> (length text) (+ 1 end-of-header-pos))
979 (websocket-server-filter process (substring
981 end-of-header-pos))))
982 (setf (websocket-inflight-input ws) text))))
983 ((eq (websocket-ready-state ws) 'open)
984 (websocket-process-input-on-open-ws ws text))
985 ((eq (websocket-ready-state ws) 'closed)
986 (message "WARNING: Should not have received further input on closed websocket")))))
988 (defun websocket-verify-client-headers (output)
989 "Verify the headers from the WEBSOCKET client connection in OUTPUT.
990 Unlike `websocket-verify-headers', this is a quieter routine. We
991 don't want to error due to a bad client, so we just print out
992 messages and a plist containing `:key', the websocket key,
993 `:protocols' and `:extensions'."
995 (let ((case-fold-search t)
997 (unless (string-match "HTTP/1.1" output)
998 (message "Websocket client connection: HTTP/1.1 not found")
1000 (unless (string-match "^Host: " output)
1001 (message "Websocket client connection: Host header not found")
1003 (unless (string-match "^Upgrade: websocket\r\n" output)
1004 (message "Websocket client connection: Upgrade: websocket not found")
1006 (if (string-match "^Sec-WebSocket-Key: \\([[:graph:]]+\\)\r\n" output)
1007 (setq plist (plist-put plist :key (match-string 1 output)))
1008 (message "Websocket client connect: No key sent")
1010 (unless (string-match "^Sec-WebSocket-Version: 13" output)
1011 (message "Websocket client connect: Websocket version 13 not found")
1013 (when (string-match "^Sec-WebSocket-Protocol:" output)
1014 (setq plist (plist-put plist :protocols (websocket-parse-repeated-field
1016 "Sec-Websocket-Protocol"))))
1017 (when (string-match "^Sec-WebSocket-Extensions:" output)
1018 (setq plist (plist-put plist :extensions (websocket-parse-repeated-field
1020 "Sec-Websocket-Extensions"))))
1023 (provide 'websocket)
1025 ;;; websocket.el ends here