;; Author: Andrew Hyatt <ahyatt at gmail dot com>
;; Maintainer: Andrew Hyatt <ahyatt at gmail dot com>
;; Keywords: Communication, Websocket, Server
-;; Version: 1.1
+;; Version: 1.4
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
accept-string
(inflight-input nil))
-(defvar websocket-version "1.1"
+(defvar websocket-version "1.4"
"Version numbers of this version of websocket.el.")
(defvar websocket-debug nil
"The websocket GUID as defined in RFC 6455.
Do not change unless the RFC changes.")
-(defvar websocket-mask-frames t
- "If true, we mask frames as defined in the spec.
-This is recommended to be true, and some servers will refuse to
-communicate with unmasked clients.")
-
(defvar websocket-callback-debug-on-error nil
"If true, when an error happens in a client callback, invoke the debugger.
Having this on can cause issues with missing frames if the debugger is
(if (= nbytes 8)
(progn
(let ((hi-32bits (lsh val -32))
- (low-32bits (logand #xffffffff val)))
+ ;; Test for systems that don't have > 32 bits, and
+ ;; for those systems just return the value.
+ (low-32bits (if (= 0 (expt 2 32))
+ val
+ (logand #xffffffff val))))
(when (or (> hi-32bits 0) (> (lsh low-32bits -29) 0))
(signal 'websocket-frame-too-large val))
(bindat-pack `((:val vec 2 u32))
(when (< (length s) n)
(throw 'websocket-incomplete-frame nil)))
-(defun websocket-encode-frame (frame)
- "Encode the FRAME struct to the binary representation."
+(defun websocket-encode-frame (frame should-mask)
+ "Encode the FRAME struct to the binary representation.
+We mask the frame or not, depending on SHOULD-MASK."
(let* ((opcode (websocket-frame-opcode frame))
(payload (websocket-frame-payload frame))
(fin (websocket-frame-completep frame))
- (payloadp (memq opcode '(continuation text binary)))
- (mask-key (when websocket-mask-frames (websocket-genbytes 4))))
+ (payloadp (and payload
+ (memq opcode '(continuation ping pong text binary))))
+ (mask-key (when should-mask (websocket-genbytes 4))))
(apply 'unibyte-string
- (append (list
- (logior (cond ((eq opcode 'continuation) 0)
- ((eq opcode 'text) 1)
- ((eq opcode 'binary) 2)
- ((eq opcode 'close) 8)
- ((eq opcode 'ping) 9)
- ((eq opcode 'pong) 10))
- (if fin 128 0)))
- (when payloadp
- (list
- (logior
- (if websocket-mask-frames 128 0)
- (cond ((< (length payload) 126) (length payload))
- ((< (length payload) 65536) 126)
- (t 127)))))
- (when (and payloadp (>= (length payload) 126))
- (append (websocket-to-bytes (length payload)
- (cond ((< (length payload) 126) 1)
- ((< (length payload) 65536) 2)
- (t 8))) nil))
- (when (and payloadp websocket-mask-frames)
- (append mask-key nil))
- (when payloadp
- (append (if websocket-mask-frames
- (websocket-mask mask-key payload)
- payload)
- nil))))))
+ (let ((val (append (list
+ (logior (cond ((eq opcode 'continuation) 0)
+ ((eq opcode 'text) 1)
+ ((eq opcode 'binary) 2)
+ ((eq opcode 'close) 8)
+ ((eq opcode 'ping) 9)
+ ((eq opcode 'pong) 10))
+ (if fin 128 0)))
+ (when payloadp
+ (list
+ (logior
+ (if should-mask 128 0)
+ (cond ((< (length payload) 126) (length payload))
+ ((< (length payload) 65536) 126)
+ (t 127)))))
+ (when (and payloadp (>= (length payload) 126))
+ (append (websocket-to-bytes
+ (length payload)
+ (cond ((< (length payload) 126) 1)
+ ((< (length payload) 65536) 2)
+ (t 8))) nil))
+ (when (and payloadp should-mask)
+ (append mask-key nil))
+ (when payloadp
+ (append (if should-mask (websocket-mask mask-key payload)
+ payload)
+ nil)))))
+ ;; We have to make sure the non-payload data is a full 32-bit frame
+ (if (= 1 (length val))
+ (append val '(0)) val)))))
(defun websocket-read-frame (s)
"Read from string S a `websocket-frame' struct with the contents.
(websocket-ensure-length s 1)
(let* ((opcode (websocket-get-opcode s))
(fin (logand 128 (websocket-get-bytes s 1)))
- (payloadp (memq opcode '(continuation text binary)))
+ (payloadp (memq opcode '(continuation text binary ping pong)))
(payload-len (when payloadp
(websocket-get-payload-len (substring s 1))))
(maskp (and
lex-ws lex-frame)))
((eq opcode 'ping)
(lambda () (websocket-send lex-ws
- (make-websocket-frame :opcode 'pong :completep t))))
+ (make-websocket-frame
+ :opcode 'pong
+ :payload (websocket-frame-payload lex-frame)
+ :completep t))))
((eq opcode 'close)
(lambda () (delete-process (websocket-conn lex-ws))))
(t (lambda ()))))))
(defun websocket-check (frame)
"Check FRAME for correctness, returning true if correct."
- (and (equal (not (memq (websocket-frame-opcode frame)
- '(continuation text binary)))
- (and (not (websocket-frame-payload frame))
- (websocket-frame-completep frame)))))
+ (or
+ ;; Text, binary, and continuation frames need payloads
+ (and (memq (websocket-frame-opcode frame) '(text binary continuation))
+ (websocket-frame-payload frame))
+ ;; Pings and pongs may optionally have them
+ (memq (websocket-frame-opcode frame) '(ping pong))
+ ;; And close shouldn't have any payload, and should always be complete.
+ (and (eq (websocket-frame-opcode frame) 'close)
+ (not (websocket-frame-payload frame))
+ (websocket-frame-completep frame))))
(defun websocket-send (websocket frame)
"To the WEBSOCKET server, send the FRAME.
(unless (websocket-openp websocket)
(signal 'websocket-closed frame))
(process-send-string (websocket-conn websocket)
- (websocket-encode-frame frame)))
+ ;; We mask only when we're a client, following the spec.
+ (websocket-encode-frame frame (not (websocket-server-p websocket)))))
(defun websocket-openp (websocket)
"Check WEBSOCKET and return non-nil if it is open, and either
(defun websocket-close (websocket)
"Close WEBSOCKET and erase all the old websocket data."
(websocket-debug websocket "Closing websocket")
+ (websocket-try-callback 'websocket-on-close 'on-close websocket)
(when (websocket-openp websocket)
(websocket-send websocket
(make-websocket-frame :opcode 'close
:completep t))
(setf (websocket-ready-state websocket) 'closed))
- (let ((buf (process-buffer (websocket-conn websocket))))
- (delete-process (websocket-conn websocket))
- (kill-buffer buf)))
+ (delete-process (websocket-conn websocket)))
(defun websocket-ensure-connected (websocket)
"If the WEBSOCKET connection is closed, open it."
(let* ((name (format "websocket to %s" url))
(url-struct (url-generic-parse-url url))
(key (websocket-genkey))
- (buf-name (format " *%s*" name))
(coding-system-for-read 'binary)
(coding-system-for-write 'binary)
(conn (if (member (url-type url-struct) '("ws" "wss"))
(port (if (= 0 (url-port url-struct))
(if (eq type 'tls) 443 80)
(url-port url-struct)))
- (host (url-host url-struct))
- (buf (get-buffer-create buf-name)))
+ (host (url-host url-struct)))
(if (eq type 'plain)
- (make-network-process :name name :buffer buf :host host
+ (make-network-process :name name :buffer nil :host host
:service port :nowait nil)
(condition-case-unless-debug nil
- (open-network-stream name buf host port :type type :nowait nil)
+ (open-network-stream name nil host port :type type :nowait nil)
(wrong-number-of-arguments
(signal 'websocket-wss-needs-emacs-24 "wss")))))
(signal 'websocket-unsupported-protocol (url-type url-struct))))
:extensions (mapcar 'car extensions)
:accept-string
(websocket-calculate-accept key))))
+ (unless conn (error "Could not establish the websocket connection to %s" url))
(process-put conn :websocket websocket)
(set-process-filter conn
(lambda (process output)
conn
(lambda (process change)
(let ((websocket (process-get process :websocket)))
- (websocket-debug websocket
- "State change to %s" change)
- (unless (eq 'closed (websocket-ready-state websocket))
+ (websocket-debug websocket "State change to %s" change)
+ (when (and
+ (member (process-status process) '(closed failed exit signal))
+ (not (eq 'closed (websocket-ready-state websocket))))
(websocket-try-callback 'websocket-on-close 'on-close websocket)))))
(set-process-query-on-exit-flag conn nil)
(process-send-string conn
connection, which should be kept in order to pass to
`websocket-server-close'."
(let* ((conn (make-network-process
- :name (format "websocket server on port %d" port)
+ :name (format "websocket server on port %s" port)
:server t
:family 'ipv4
+ :filter 'websocket-server-filter
:log 'websocket-server-accept
:filter-multibyte nil
:plist plist
:server-conn server
:conn client
:url client
+ :server-p t
:on-open (or (process-get server :on-open) 'identity)
:on-message (or (process-get server :on-message) (lambda (_ws _frame)))
:on-close (lexical-let ((user-method
:extensions (mapcar 'car (process-get server :extensions)))))
(unless (member ws websocket-server-websockets)
(push ws websocket-server-websockets))
- (set-process-coding-system client 'unix 'unix)
(process-put client :websocket ws)
- (set-process-filter client 'websocket-server-filter)
- (set-process-coding-system client 'binary)
+ (set-process-coding-system client 'binary 'binary)
(set-process-sentinel client
(lambda (process change)
(let ((websocket (process-get process :websocket)))
(websocket-debug websocket "State change to %s" change)
- (unless (eq 'closed (websocket-ready-state websocket))
+ (when (and
+ (member (process-status process) '(closed failed exit signal))
+ (not (eq 'closed (websocket-ready-state websocket))))
(websocket-try-callback 'websocket-on-close 'on-close websocket)))))))
(defun websocket-create-headers (url key protocol extensions)
"Upgrade: websocket\r\n"
"Connection: Upgrade\r\n"
"Sec-WebSocket-Key: %s\r\n"
- "Origin: %s\r\n"
"Sec-WebSocket-Version: 13\r\n"
(when protocol
(concat
"\r\n")
(url-host (url-generic-parse-url url))
key
- system-name
protocol))
(defun websocket-get-server-response (websocket client-protocols client-extensions)