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.
49 (eval-when-compile (require 'cl))
55 (:constructor websocket-inner-create))
56 "A websocket structure.
57 This follows the W3C Websocket API, except translated to elisp
58 idioms. The API is implemented in both the websocket struct and
59 additional methods. Due to how defstruct slots are accessed, all
60 API methods are prefixed with \"websocket-\" and take a websocket
61 as an argument, so the distrinction between the struct API and
62 the additional helper APIs are not visible to the caller.
64 A websocket struct is created with `websocket-open'.
66 `ready-state' contains one of 'connecting, 'open, or
67 'closed, depending on the state of the websocket.
69 The W3C API \"bufferedAmount\" call is not currently implemented,
70 since there is no elisp API to get the buffered amount from the
71 subprocess. There may, in fact, be output data buffered,
72 however, when the `on-message' or `on-close' callbacks are
75 `on-open', `on-message', `on-close', and `on-error' are described
78 The `negotiated-extensions' slot lists the extensions accepted by
79 both the client and server, and `negotiated-protocols' does the
80 same for the protocols.
83 (ready-state 'connecting)
91 (server-p nil :read-only t)
93 ;; Other data - clients should not have to access this.
94 (url (assert nil) :read-only t)
95 (protocols nil :read-only t)
96 (extensions nil :read-only t)
97 (conn (assert nil) :read-only t)
98 ;; Only populated for servers, this is the server connection.
101 (inflight-input nil))
103 (defvar websocket-version "1.5"
104 "Version numbers of this version of websocket.el.")
106 (defvar websocket-debug nil
107 "Set to true to output debugging info to a per-websocket buffer.
108 The buffer is ` *websocket URL debug*' where URL is the
109 URL of the connection.")
111 (defconst websocket-guid "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
112 "The websocket GUID as defined in RFC 6455.
113 Do not change unless the RFC changes.")
115 (defvar websocket-callback-debug-on-error nil
116 "If true, when an error happens in a client callback, invoke the debugger.
117 Having this on can cause issues with missing frames if the debugger is
118 exited by quitting instead of continuing, so it's best to have this set
119 to nil unless it is especially needed.")
121 (defmacro websocket-document-function (function docstring)
122 "Document FUNCTION with DOCSTRING. Use this for defstruct accessor etc."
123 (declare (indent defun)
125 `(put ',function 'function-documentation ,docstring))
127 (websocket-document-function websocket-on-open
128 "Accessor for websocket on-open callback.
129 See `websocket-open' for details.
133 (websocket-document-function websocket-on-message
134 "Accessor for websocket on-message callback.
135 See `websocket-open' for details.
139 (websocket-document-function websocket-on-close
140 "Accessor for websocket on-close callback.
141 See `websocket-open' for details.
145 (websocket-document-function websocket-on-error
146 "Accessor for websocket on-error callback.
147 See `websocket-open' for details.
151 (defun websocket-genbytes (nbytes)
152 "Generate NBYTES random bytes."
153 (let ((s (make-string nbytes ?\s)))
155 (aset s i (random 256)))
158 (defun websocket-try-callback (websocket-callback callback-type websocket
160 "Invoke function WEBSOCKET-CALLBACK with WEBSOCKET and REST args.
161 If an error happens, it is handled according to
162 `websocket-callback-debug-on-error'."
163 ;; This looks like it should be able to done more efficiently, but
164 ;; I'm not sure that's the case. We can't do it as a macro, since
165 ;; we want it to change whenever websocket-callback-debug-on-error
168 (debug-on-error websocket-callback-debug-on-error))
169 (push websocket args)
170 (if websocket-callback-debug-on-error
172 (apply (funcall websocket-callback websocket) args)
173 ((debug error) (funcall (websocket-on-error websocket)
174 websocket callback-type err)))
176 (apply (funcall websocket-callback websocket) args)
177 (error (funcall (websocket-on-error websocket) websocket
178 callback-type err))))))
180 (defun websocket-genkey ()
181 "Generate a key suitable for the websocket handshake."
182 (base64-encode-string (websocket-genbytes 16)))
184 (defun websocket-calculate-accept (key)
185 "Calculate the expect value of the accept header.
186 This is based on the KEY from the Sec-WebSocket-Key header."
187 (base64-encode-string
188 (sha1 (concat key websocket-guid) nil nil t)))
190 (defun websocket-get-bytes (s n)
191 "From string S, retrieve the value of N bytes.
192 Return the value as an unsigned integer. The value N must be a
195 We support getting frames up to 536870911 bytes (2^29 - 1),
196 approximately 537M long."
199 (bindat-get-field (bindat-unpack '((:val vec 2 u32)) s) :val))
201 (logior (lsh (aref 32-bit-parts 0) 32) (aref 32-bit-parts 1))))
202 (if (and (= (aref 32-bit-parts 0) 0)
203 (= (lsh (aref 32-bit-parts 1) -29) 0))
205 (signal 'websocket-unparseable-frame
206 "Frame value found too large to parse!")))
215 ;; This is an error with the library,
216 ;; not a user-facing, meaningful error.
218 "websocket-get-bytes: Unknown N: %s" n)))))
220 (args-out-of-range (signal 'websocket-unparseable-frame
221 (format "Frame unexpectedly shortly: %s" s))))
224 (defun websocket-to-bytes (val nbytes)
225 "Encode the integer VAL in NBYTES of data.
226 NBYTES much be a power of 2, up to 8.
228 This supports encoding values up to 536870911 bytes (2^29 - 1),
229 approximately 537M long."
230 (when (and (< nbytes 8)
231 (> val (expt 2 (* 8 nbytes))))
232 ;; not a user-facing error, this must be caused from an error in
234 (error "websocket-to-bytes: Value %d could not be expressed in %d bytes"
238 (let ((hi-32bits (lsh val -32))
239 ;; Test for systems that don't have > 32 bits, and
240 ;; for those systems just return the value.
241 (low-32bits (if (= 0 (expt 2 32))
243 (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 should-mask)
299 "Encode the FRAME struct to the binary representation.
300 We mask the frame or not, depending on SHOULD-MASK."
301 (let* ((opcode (websocket-frame-opcode frame))
302 (payload (websocket-frame-payload frame))
303 (fin (websocket-frame-completep frame))
304 (payloadp (and payload
305 (memq opcode '(continuation ping pong text binary))))
306 (mask-key (when should-mask (websocket-genbytes 4))))
307 (apply 'unibyte-string
308 (let ((val (append (list
309 (logior (cond ((eq opcode 'continuation) 0)
310 ((eq opcode 'text) 1)
311 ((eq opcode 'binary) 2)
312 ((eq opcode 'close) 8)
313 ((eq opcode 'ping) 9)
314 ((eq opcode 'pong) 10))
319 (if should-mask 128 0)
320 (cond ((< (length payload) 126) (length payload))
321 ((< (length payload) 65536) 126)
323 (when (and payloadp (>= (length payload) 126))
324 (append (websocket-to-bytes
326 (cond ((< (length payload) 126) 1)
327 ((< (length payload) 65536) 2)
329 (when (and payloadp should-mask)
330 (append mask-key nil))
332 (append (if should-mask (websocket-mask mask-key payload)
335 ;; We have to make sure the non-payload data is a full 32-bit frame
336 (if (= 1 (length val))
337 (append val '(0)) val)))))
339 (defun websocket-read-frame (s)
340 "Read from string S a `websocket-frame' struct with the contents.
341 This only gets complete frames. Partial frames need to wait until
342 the frame finishes. If the frame is not completed, return NIL."
343 (catch 'websocket-incomplete-frame
344 (websocket-ensure-length s 1)
345 (let* ((opcode (websocket-get-opcode s))
346 (fin (logand 128 (websocket-get-bytes s 1)))
347 (payloadp (memq opcode '(continuation text binary ping pong)))
348 (payload-len (when payloadp
349 (websocket-get-payload-len (substring s 1))))
352 (= 128 (logand 128 (websocket-get-bytes (substring s 1) 1)))))
353 (payload-start (when payloadp (+ (if maskp 5 1) (cdr payload-len))))
354 (payload-end (when payloadp (+ payload-start (car payload-len))))
355 (unmasked-payload (when payloadp
356 (websocket-ensure-length s payload-end)
357 (substring s payload-start payload-end))))
358 (make-websocket-frame
362 (let ((masking-key (substring s (+ 1 (cdr payload-len))
363 (+ 5 (cdr payload-len)))))
364 (websocket-mask masking-key unmasked-payload))
366 :length (if payloadp payload-end 1)
367 :completep (> fin 0)))))
369 (defun websocket-format-error (err)
370 "Format an error message like command level does.
371 ERR should be a cons of error symbol and error data."
373 ;; Formatting code adapted from `edebug-report-error'
374 (concat (or (get (car err) 'error-message)
375 (format "peculiar error (%s)" (car err)))
378 (mapconcat #'prin1-to-string
381 (defun websocket-default-error-handler (_websocket type err)
382 "The default error handler used to handle errors in callbacks."
383 (display-warning 'websocket
384 (format "in callback `%S': %s"
386 (websocket-format-error err))
389 ;; Error symbols in use by the library
390 (put 'websocket-unsupported-protocol 'error-conditions
391 '(error websocket-error websocket-unsupported-protocol))
392 (put 'websocket-unsupported-protocol 'error-message "Unsupported websocket protocol")
393 (put 'websocket-wss-needs-emacs-24 'error-conditions
394 '(error websocket-error websocket-unsupported-protocol
395 websocket-wss-needs-emacs-24))
396 (put 'websocket-wss-needs-emacs-24 'error-message
397 "wss protocol is not supported for Emacs before version 24.")
398 (put 'websocket-received-error-http-response 'error-conditions
399 '(error websocket-error websocket-received-error-http-response))
400 (put 'websocket-received-error-http-response 'error-message
401 "Error response received from websocket server")
402 (put 'websocket-invalid-header 'error-conditions
403 '(error websocket-error websocket-invalid-header))
404 (put 'websocket-invalid-header 'error-message
405 "Invalid HTTP header sent")
406 (put 'websocket-illegal-frame 'error-conditions
407 '(error websocket-error websocket-illegal-frame))
408 (put 'websocket-illegal-frame 'error-message
409 "Cannot send illegal frame to websocket")
410 (put 'websocket-closed 'error-conditions
411 '(error websocket-error websocket-closed))
412 (put 'websocket-closed 'error-message
413 "Cannot send message to a closed websocket")
414 (put 'websocket-unparseable-frame 'error-conditions
415 '(error websocket-error websocket-unparseable-frame))
416 (put 'websocket-unparseable-frame 'error-message
417 "Received an unparseable frame")
418 (put 'websocket-frame-too-large 'error-conditions
419 '(error websocket-error websocket-frame-too-large))
420 (put 'websocket-frame-too-large 'error-message
421 "The frame being sent is too large for this emacs to handle")
423 (defun websocket-intersect (a b)
424 "Simple list intersection, should function like Common Lisp's `intersection'."
426 (dolist (elem a (nreverse result))
427 (when (member elem b)
428 (push elem result)))))
430 (defun websocket-get-debug-buffer-create (websocket)
431 "Get or create the buffer corresponding to WEBSOCKET."
432 (let ((buf (get-buffer-create (format "*websocket %s debug*"
433 (websocket-url websocket)))))
434 (when (= 0 (buffer-size buf))
435 (buffer-disable-undo buf))
438 (defun websocket-debug (websocket msg &rest args)
439 "In the WEBSOCKET's debug buffer, send MSG, with format ARGS."
440 (when websocket-debug
441 (let ((buf (websocket-get-debug-buffer-create websocket)))
443 (with-current-buffer buf
444 (goto-char (point-max))
446 (insert (apply 'format (append (list msg) args)))
449 (defun websocket-verify-response-code (output)
450 "Verify that OUTPUT contains a valid HTTP response code.
451 The only acceptable one to websocket is responce code 101.
452 A t value will be returned on success, and an error thrown
454 (string-match "HTTP/1.1 \\([[:digit:]]+\\)" output)
455 (unless (equal "101" (match-string 1 output))
456 (signal 'websocket-received-error-http-response
457 (string-to-number (match-string 1 output))))
460 (defun websocket-parse-repeated-field (output field)
461 "From header-containing OUTPUT, parse out the list from a
462 possibly repeated field."
466 (string-match (format "\r\n%s: \\(.*\\)\r\n" field)
468 (when (setq pos (match-end 1))
469 (setq extensions (append extensions (split-string
470 (match-string 1 output) ", ?")))))
473 (defun websocket-process-frame (websocket frame)
474 "Using the WEBSOCKET's filter and connection, process the FRAME.
475 This returns a lambda that should be executed when all frames have
476 been processed. If the frame has a payload, the lambda has the frame
477 passed to the filter slot of WEBSOCKET. If the frame is a ping,
478 the lambda has a reply with a pong. If the frame is a close, the lambda
479 has connection termination."
480 (let ((opcode (websocket-frame-opcode frame)))
481 (lexical-let ((lex-ws websocket)
483 (cond ((memq opcode '(continuation text binary))
484 (lambda () (websocket-try-callback 'websocket-on-message 'on-message
487 (lambda () (websocket-send lex-ws
488 (make-websocket-frame
490 :payload (websocket-frame-payload lex-frame)
493 (lambda () (delete-process (websocket-conn lex-ws))))
496 (defun websocket-process-input-on-open-ws (websocket text)
497 "This handles input processing for both the client and server filters."
498 (let ((current-frame)
501 (while (setq current-frame (websocket-read-frame
502 (substring text start-point)))
503 (push (websocket-process-frame websocket current-frame) processing-queue)
504 (incf start-point (websocket-frame-length current-frame)))
505 (when (> (length text) start-point)
506 (setf (websocket-inflight-input websocket)
507 (substring text start-point)))
508 (dolist (to-process (nreverse processing-queue))
509 (funcall to-process))))
511 (defun websocket-send-text (websocket text)
512 "To the WEBSOCKET, send TEXT as a complete frame."
515 (make-websocket-frame :opcode 'text
516 :payload (encode-coding-string
520 (defun websocket-check (frame)
521 "Check FRAME for correctness, returning true if correct."
523 ;; Text, binary, and continuation frames need payloads
524 (and (memq (websocket-frame-opcode frame) '(text binary continuation))
525 (websocket-frame-payload frame))
526 ;; Pings and pongs may optionally have them
527 (memq (websocket-frame-opcode frame) '(ping pong))
528 ;; And close shouldn't have any payload, and should always be complete.
529 (and (eq (websocket-frame-opcode frame) 'close)
530 (not (websocket-frame-payload frame))
531 (websocket-frame-completep frame))))
533 (defun websocket-send (websocket frame)
534 "To the WEBSOCKET server, send the FRAME.
535 This will raise an error if the frame is illegal.
537 The error signaled may be of type `websocket-illegal-frame' if
538 the frame is malformed in some way, also having the condition
539 type of `websocket-error'. The data associated with the signal
540 is the frame being sent.
542 If the websocket is closed a signal `websocket-closed' is sent,
543 also with `websocket-error' condition. The data in the signal is
546 The frame may be too large for this buid of Emacs, in which case
547 `websocket-frame-too-large' is returned, with the data of the
548 size of the frame which was too large to process. This also has
549 the `websocket-error' condition."
550 (unless (websocket-check frame)
551 (signal 'websocket-illegal-frame frame))
552 (websocket-debug websocket "Sending frame, opcode: %s payload: %s"
553 (websocket-frame-opcode frame)
554 (websocket-frame-payload frame))
555 (websocket-ensure-connected websocket)
556 (unless (websocket-openp websocket)
557 (signal 'websocket-closed frame))
558 (process-send-string (websocket-conn websocket)
559 ;; We mask only when we're a client, following the spec.
560 (websocket-encode-frame frame (not (websocket-server-p websocket)))))
562 (defun websocket-openp (websocket)
563 "Check WEBSOCKET and return non-nil if it is open, and either
566 (not (eq 'close (websocket-ready-state websocket)))
567 (member (process-status (websocket-conn websocket)) '(open run))))
569 (defun websocket-close (websocket)
570 "Close WEBSOCKET and erase all the old websocket data."
571 (websocket-debug websocket "Closing websocket")
572 (websocket-try-callback 'websocket-on-close 'on-close websocket)
573 (when (websocket-openp websocket)
574 (websocket-send websocket
575 (make-websocket-frame :opcode 'close
577 (setf (websocket-ready-state websocket) 'closed))
578 (delete-process (websocket-conn websocket)))
580 (defun websocket-ensure-connected (websocket)
581 "If the WEBSOCKET connection is closed, open it."
582 (unless (and (websocket-conn websocket)
583 (ecase (process-status (websocket-conn websocket))
584 ((run open listen) t)
585 ((stop exit signal closed connect failed nil) nil)))
586 (websocket-close websocket)
587 (websocket-open (websocket-url websocket)
588 :protocols (websocket-protocols websocket)
589 :extensions (websocket-extensions websocket)
590 :on-open (websocket-on-open websocket)
591 :on-message (websocket-on-message websocket)
592 :on-close (websocket-on-close websocket)
593 :on-error (websocket-on-error websocket))))
595 ;;;;;;;;;;;;;;;;;;;;;;
596 ;; Websocket client ;;
597 ;;;;;;;;;;;;;;;;;;;;;;
599 (defun* websocket-open (url &key protocols extensions (on-open 'identity)
600 (on-message (lambda (_w _f))) (on-close 'identity)
601 (on-error 'websocket-default-error-handler))
602 "Open a websocket connection to URL, returning the `websocket' struct.
603 The PROTOCOL argument is optional, and setting it will declare to
604 the server that this client supports the protocols in the list
605 given. We will require that the server also has to support that
608 Similar logic applies to EXTENSIONS, which is a list of conses,
609 the car of which is a string naming the extension, and the cdr of
610 which is the list of parameter strings to use for that extension.
611 The parameter strings are of the form \"key=value\" or \"value\".
612 EXTENSIONS can be NIL if none are in use. An example value would
613 be '(\"deflate-stream\" . (\"mux\" \"max-channels=4\")).
615 Cookies that are set via `url-cookie-store' will be used during
616 communication with the server, and cookies received from the
617 server will be stored in the same cookie storage that the
618 `url-cookie' package uses.
620 Optionally you can specify
621 ON-OPEN, ON-MESSAGE and ON-CLOSE callbacks as well.
623 The ON-OPEN callback is called after the connection is
624 established with the websocket as the only argument. The return
627 The ON-MESSAGE callback is called after receiving a frame, and is
628 called with the websocket as the first argument and
629 `websocket-frame' struct as the second. The return value is
632 The ON-CLOSE callback is called after the connection is closed, or
633 failed to open. It is called with the websocket as the only
634 argument, and the return value is unused.
636 The ON-ERROR callback is called when any of the other callbacks
637 have an error. It takes the websocket as the first argument, and
638 a symbol as the second argument either `on-open', `on-message',
639 or `on-close', and the error as the third argument. Do NOT
640 rethrow the error, or else you may miss some websocket messages.
641 You similarly must not generate any other errors in this method.
642 If you want to debug errors, set
643 `websocket-callback-debug-on-error' to `t', but this also can be
644 dangerous is the debugger is quit out of. If not specified,
645 `websocket-default-error-handler' is used.
647 For each of these event handlers, the client code can store
648 arbitrary data in the `client-data' slot in the returned
651 The following errors might be thrown in this method or in
652 websocket processing, all of them having the error-condition
653 `websocket-error' in addition to their own symbol:
655 `websocket-unsupported-protocol': Data in the error signal is the
656 protocol that is unsupported. For example, giving a URL starting
657 with http by mistake raises this error.
659 `websocket-wss-needs-emacs-24': Trying to connect wss protocol
660 using Emacs < 24 raises this error. You can catch this error
661 also by `websocket-unsupported-protocol'.
663 `websocket-received-error-http-response': Data in the error
664 signal is the integer error number.
666 `websocket-invalid-header': Data in the error is a string
667 describing the invalid header received from the server.
669 `websocket-unparseable-frame': Data in the error is a string
670 describing the problem with the frame.
672 (let* ((name (format "websocket to %s" url))
673 (url-struct (url-generic-parse-url url))
674 (key (websocket-genkey))
675 (coding-system-for-read 'binary)
676 (coding-system-for-write 'binary)
677 (conn (if (member (url-type url-struct) '("ws" "wss"))
678 (let* ((type (if (equal (url-type url-struct) "ws")
680 (port (if (= 0 (url-port url-struct))
681 (if (eq type 'tls) 443 80)
682 (url-port url-struct)))
683 (host (url-host url-struct)))
685 (make-network-process :name name :buffer nil :host host
686 :service port :nowait nil)
687 (condition-case-unless-debug nil
688 (open-network-stream name nil host port :type type :nowait nil)
689 (wrong-number-of-arguments
690 (signal 'websocket-wss-needs-emacs-24 "wss")))))
691 (signal 'websocket-unsupported-protocol (url-type url-struct))))
692 (websocket (websocket-inner-create
696 :on-message on-message
700 :extensions (mapcar 'car extensions)
702 (websocket-calculate-accept key))))
703 (unless conn (error "Could not establish the websocket connection to %s" url))
704 (process-put conn :websocket websocket)
705 (set-process-filter conn
706 (lambda (process output)
707 (let ((websocket (process-get process :websocket)))
708 (websocket-outer-filter websocket output))))
709 (set-process-sentinel
711 (lambda (process change)
712 (let ((websocket (process-get process :websocket)))
713 (websocket-debug websocket "State change to %s" change)
715 (member (process-status process) '(closed failed exit signal))
716 (not (eq 'closed (websocket-ready-state websocket))))
717 (websocket-try-callback 'websocket-on-close 'on-close websocket)))))
718 (set-process-query-on-exit-flag conn nil)
719 (process-send-string conn
720 (format "GET %s HTTP/1.1\r\n"
721 (let ((path (url-filename url-struct)))
722 (if (> (length path) 0) path "/"))))
723 (websocket-debug websocket "Sending handshake, key: %s, acceptance: %s"
724 key (websocket-accept-string websocket))
725 (process-send-string conn
726 (websocket-create-headers url key protocols extensions))
727 (websocket-debug websocket "Websocket opened")
730 (defun websocket-process-headers (url headers)
731 "On opening URL, process the HEADERS sent from the server."
732 (when (string-match "Set-Cookie: \(.*\)\r\n" headers)
733 ;; The url-current-object is assumed to be set by
734 ;; url-cookie-handle-set-cookie.
735 (let ((url-current-object (url-generic-parse-url url)))
736 (url-cookie-handle-set-cookie (match-string 1 headers)))))
738 (defun websocket-outer-filter (websocket output)
739 "Filter the WEBSOCKET server's OUTPUT.
740 This will parse headers and process frames repeatedly until there
741 is no more output or the connection closes. If the websocket
742 connection is invalid, the connection will be closed."
743 (websocket-debug websocket "Received: %s" output)
745 (text (concat (websocket-inflight-input websocket) output))
747 (setf (websocket-inflight-input websocket) nil)
748 ;; If we've received the complete header, check to see if we've
749 ;; received the desired handshake.
750 (when (and (eq 'connecting (websocket-ready-state websocket))
751 (setq header-end-pos (string-match "\r\n\r\n" text))
752 (setq start-point (+ 4 header-end-pos)))
755 (websocket-verify-response-code text)
756 (websocket-verify-headers websocket text)
757 (websocket-process-headers (websocket-url websocket) text))
759 (websocket-close websocket)
760 (signal (car err) (cdr err))))
761 (setf (websocket-ready-state websocket) 'open)
762 (websocket-try-callback 'websocket-on-open 'on-open websocket))
763 (when (eq 'open (websocket-ready-state websocket))
764 (websocket-process-input-on-open-ws
765 websocket (substring text (or start-point 0))))))
767 (defun websocket-verify-headers (websocket output)
768 "Based on WEBSOCKET's data, ensure the headers in OUTPUT are valid.
769 The output is assumed to have complete headers. This function
770 will either return t or call `error'. This has the side-effect
771 of populating the list of server extensions to WEBSOCKET."
773 (concat "Sec-WebSocket-Accept: " (websocket-accept-string websocket))))
774 (websocket-debug websocket "Checking for accept header: %s" accept-string)
775 (unless (string-match (regexp-quote accept-string) output)
776 (signal 'websocket-invalid-header
777 "Incorrect handshake from websocket: is this really a websocket connection?")))
778 (let ((case-fold-search t))
779 (websocket-debug websocket "Checking for upgrade header")
780 (unless (string-match "\r\nUpgrade: websocket\r\n" output)
781 (signal 'websocket-invalid-header
782 "No 'Upgrade: websocket' header found"))
783 (websocket-debug websocket "Checking for connection header")
784 (unless (string-match "\r\nConnection: upgrade\r\n" output)
785 (signal 'websocket-invalid-header
786 "No 'Connection: upgrade' header found"))
787 (when (websocket-protocols websocket)
788 (dolist (protocol (websocket-protocols websocket))
789 (websocket-debug websocket "Checking for protocol match: %s"
792 (if (string-match (format "\r\nSec-Websocket-Protocol: %s\r\n"
796 (signal 'websocket-invalid-header
797 "Incorrect or missing protocol returned by the server."))))
798 (setf (websocket-negotiated-protocols websocket) protocols))))
799 (let* ((extensions (websocket-parse-repeated-field
801 "Sec-WebSocket-Extensions"))
803 (dolist (ext extensions)
804 (let ((x (first (split-string ext "; ?"))))
805 (unless (or (member x (websocket-extensions websocket))
806 (member x extra-extensions))
807 (push x extra-extensions))))
808 (when extra-extensions
809 (signal 'websocket-invalid-header
810 (format "Non-requested extensions returned by server: %S"
812 (setf (websocket-negotiated-extensions websocket) extensions)))
815 ;;;;;;;;;;;;;;;;;;;;;;
816 ;; Websocket server ;;
817 ;;;;;;;;;;;;;;;;;;;;;;
819 (defvar websocket-server-websockets nil
820 "A list of current websockets live on any server.")
822 (defun* websocket-server (port &rest plist)
823 "Open a websocket server on PORT.
824 This also takes a plist of callbacks: `:on-open', `:on-message',
825 `:on-close' and `:on-error', which operate exactly as documented
826 in the websocket client function `websocket-open'. Returns the
827 connection, which should be kept in order to pass to
828 `websocket-server-close'."
829 (let* ((conn (make-network-process
830 :name (format "websocket server on port %s" port)
833 :filter 'websocket-server-filter
834 :log 'websocket-server-accept
835 :filter-multibyte nil
840 (defun websocket-server-close (conn)
841 "Closes the websocket, as well as all open websockets for this server."
843 (dolist (ws websocket-server-websockets)
844 (when (eq (websocket-server-conn ws) conn)
845 (if (eq (websocket-ready-state ws) 'closed)
846 (unless (member ws to-delete)
848 (websocket-close ws))))
849 (dolist (ws to-delete)
850 (setq websocket-server-websockets (remove ws websocket-server-websockets))))
851 (delete-process conn))
853 (defun websocket-server-accept (server client message)
854 "Accept a new websocket connection from a client."
855 (let ((ws (websocket-inner-create
860 :on-open (or (process-get server :on-open) 'identity)
861 :on-message (or (process-get server :on-message) (lambda (_ws _frame)))
862 :on-close (lexical-let ((user-method
863 (or (process-get server :on-close) 'identity)))
865 (setq websocket-server-websockets
866 (remove ws websocket-server-websockets))
867 (funcall user-method ws)))
868 :on-error (or (process-get server :on-error)
869 'websocket-default-error-handler)
870 :protocols (process-get server :protocol)
871 :extensions (mapcar 'car (process-get server :extensions)))))
872 (unless (member ws websocket-server-websockets)
873 (push ws websocket-server-websockets))
874 (process-put client :websocket ws)
875 (set-process-coding-system client 'binary 'binary)
876 (set-process-sentinel client
877 (lambda (process change)
878 (let ((websocket (process-get process :websocket)))
879 (websocket-debug websocket "State change to %s" change)
881 (member (process-status process) '(closed failed exit signal))
882 (not (eq 'closed (websocket-ready-state websocket))))
883 (websocket-try-callback 'websocket-on-close 'on-close websocket)))))))
885 (defun websocket-create-headers (url key protocol extensions)
886 "Create connections headers for the given URL, KEY, PROTOCOL and EXTENSIONS.
887 These are defined as in `websocket-open'."
888 (let* ((parsed-url (url-generic-parse-url url))
889 (host-port (if (url-port-if-non-default parsed-url)
890 (format "%s:%s" (url-host parsed-url) (url-port parsed-url))
891 (url-host parsed-url)))
892 (cookie-header (url-cookie-generate-header-lines
893 host-port (car (url-path-and-query parsed-url))
894 (equal (url-type parsed-url) "wss"))))
895 (format (concat "Host: %s\r\n"
896 "Upgrade: websocket\r\n"
897 "Connection: Upgrade\r\n"
898 "Sec-WebSocket-Key: %s\r\n"
899 "Sec-WebSocket-Version: 13\r\n"
904 (format "Sec-WebSocket-Protocol: %s" protocol))
908 (format "Sec-WebSocket-Extensions: %s\r\n"
913 (when (cdr ext) "; ")
915 (mapconcat 'identity (cdr ext) "; "))))
917 (when cookie-header cookie-header)
923 (defun websocket-get-server-response (websocket client-protocols client-extensions)
924 "Get the websocket response from client WEBSOCKET."
925 (let ((separator "\r\n"))
926 (concat "HTTP/1.1 101 Switching Protocols" separator
927 "Upgrade: websocket" separator
928 "Connection: Upgrade" separator
929 "Sec-WebSocket-Accept: "
930 (websocket-accept-string websocket) separator
932 (websocket-intersect client-protocols
933 (websocket-protocols websocket))))
937 (lambda (protocol) (format "Sec-WebSocket-Protocol: %s"
938 protocol)) protocols separator)
940 (let ((extensions (websocket-intersect
942 (websocket-extensions websocket))))
946 (lambda (extension) (format "Sec-Websocket-Extensions: %s"
947 extension)) extensions separator)
951 (defun websocket-server-filter (process output)
952 "This acts on all OUTPUT from websocket clients PROCESS."
953 (let* ((ws (process-get process :websocket))
954 (text (concat (websocket-inflight-input ws) output)))
955 (setf (websocket-inflight-input ws) nil)
956 (cond ((eq (websocket-ready-state ws) 'connecting)
957 ;; check for connection string
958 (let ((end-of-header-pos
959 (let ((pos (string-match "\r\n\r\n" text)))
960 (when pos (+ 4 pos)))))
961 (if end-of-header-pos
963 (let ((header-info (websocket-verify-client-headers text)))
965 (progn (setf (websocket-accept-string ws)
966 (websocket-calculate-accept
967 (plist-get header-info :key)))
970 (websocket-get-server-response
971 ws (plist-get header-info :protocols)
972 (plist-get header-info :extensions)))
973 (setf (websocket-ready-state ws) 'open)
974 (websocket-try-callback 'websocket-on-open
976 (message "Invalid client headers found in: %s" output)
977 (process-send-string process "HTTP/1.1 400 Bad Request\r\n\r\n")
978 (websocket-close ws)))
979 (when (> (length text) (+ 1 end-of-header-pos))
980 (websocket-server-filter process (substring
982 end-of-header-pos))))
983 (setf (websocket-inflight-input ws) text))))
984 ((eq (websocket-ready-state ws) 'open)
985 (websocket-process-input-on-open-ws ws text))
986 ((eq (websocket-ready-state ws) 'closed)
987 (message "WARNING: Should not have received further input on closed websocket")))))
989 (defun websocket-verify-client-headers (output)
990 "Verify the headers from the WEBSOCKET client connection in OUTPUT.
991 Unlike `websocket-verify-headers', this is a quieter routine. We
992 don't want to error due to a bad client, so we just print out
993 messages and a plist containing `:key', the websocket key,
994 `:protocols' and `:extensions'."
996 (let ((case-fold-search t)
998 (unless (string-match "HTTP/1.1" output)
999 (message "Websocket client connection: HTTP/1.1 not found")
1001 (unless (string-match "^Host: " output)
1002 (message "Websocket client connection: Host header not found")
1004 (unless (string-match "^Upgrade: websocket\r\n" output)
1005 (message "Websocket client connection: Upgrade: websocket not found")
1007 (if (string-match "^Sec-WebSocket-Key: \\([[:graph:]]+\\)\r\n" output)
1008 (setq plist (plist-put plist :key (match-string 1 output)))
1009 (message "Websocket client connect: No key sent")
1011 (unless (string-match "^Sec-WebSocket-Version: 13" output)
1012 (message "Websocket client connect: Websocket version 13 not found")
1014 (when (string-match "^Sec-WebSocket-Protocol:" output)
1015 (setq plist (plist-put plist :protocols (websocket-parse-repeated-field
1017 "Sec-Websocket-Protocol"))))
1018 (when (string-match "^Sec-WebSocket-Extensions:" output)
1019 (setq plist (plist-put plist :extensions (websocket-parse-repeated-field
1021 "Sec-Websocket-Extensions"))))
1024 (provide 'websocket)
1026 ;;; websocket.el ends here