X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/7b78b37f6ae1588e7c91c0edb4ae341f4bad868c..f9b63e405daf25088fa663c3a1c65f66701b914a:/packages/websocket/websocket.el

diff --git a/packages/websocket/websocket.el b/packages/websocket/websocket.el
index 969e70b26..1e1baa369 100644
--- a/packages/websocket/websocket.el
+++ b/packages/websocket/websocket.el
@@ -5,7 +5,7 @@
 ;; Author: Andrew Hyatt <ahyatt at gmail dot com>
 ;; Maintainer: Andrew Hyatt <ahyatt at gmail dot com>
 ;; Keywords: Communication, Websocket, Server
-;; Version: 1.3
+;; 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
@@ -99,7 +99,7 @@ same for the protocols.
   accept-string
   (inflight-input nil))
 
-(defvar websocket-version "1.3"
+(defvar websocket-version "1.4"
   "Version numbers of this version of websocket.el.")
 
 (defvar websocket-debug nil
@@ -235,7 +235,11 @@ approximately 537M long."
   (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))
@@ -296,35 +300,40 @@ 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)))
+         (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 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))))))
+           (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.
@@ -334,7 +343,7 @@ the frame finishes.  If the frame is not completed, return NIL."
     (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
@@ -475,7 +484,10 @@ has connection termination."
                                            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 ()))))))
@@ -506,10 +518,16 @@ has connection termination."
 
 (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.