elpa/websocket-1.8/websocket.el

   1 ;;; websocket.el --- Emacs WebSocket client and server
   2
   3 ;; Copyright (c) 2013, 2016  Free Software Foundation, Inc.
   4
   5 ;; Author: Andrew Hyatt <ahyatt@gmail.com>
   6 ;; Keywords: Communication, Websocket, Server
   7 ;; Version: 1.8
   8 ;;
   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.
  13 ;;
  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.
  18 ;;
  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/>.
  21
  22 ;;; Commentary:
  23 ;; This implements RFC 6455, which can be found at
  24 ;; http://tools.ietf.org/html/rfc6455.
  25 ;;
  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
  28 ;; connections.
  29 ;;
  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'.
  38 ;;
  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.
  44
  45 (require 'bindat)
  46 (require 'url-parse)
  47 (require 'url-cookie)
  48 (eval-when-compile (require 'cl))
  49
  50 ;;; Code:
  51
  52 (defstruct (websocket
  53             (:constructor nil)
  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.
  62
  63 A websocket struct is created with `websocket-open'.
  64
  65 `ready-state' contains one of `connecting', `open', or
  66 `closed', depending on the state of the websocket.
  67
  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
  72 called.
  73
  74 `on-open', `on-message', `on-close', and `on-error' are described
  75 in `websocket-open'.
  76
  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.
  80 "
  81   ;; API
  82   (ready-state 'connecting)
  83   client-data
  84   on-open
  85   on-message
  86   on-close
  87   on-error
  88   negotiated-protocols
  89   negotiated-extensions
  90   (server-p nil :read-only t)
  91
  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.
  98   server-conn
  99   accept-string
 100   (inflight-input nil))
 101
 102 (defvar websocket-version "1.5"
 103   "Version numbers of this version of websocket.el.")
 104
 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.")
 109
 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.")
 113
 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.")
 119
 120 (defmacro websocket-document-function (function docstring)
 121   "Document FUNCTION with DOCSTRING.  Use this for defstruct accessor etc."
 122   (declare (indent defun)
 123            (doc-string 2))
 124   `(put ',function 'function-documentation ,docstring))
 125
 126 (websocket-document-function websocket-on-open
 127   "Accessor for websocket on-open callback.
 128 See `websocket-open' for details.
 129
 130 \(fn WEBSOCKET)")
 131
 132 (websocket-document-function websocket-on-message
 133   "Accessor for websocket on-message callback.
 134 See `websocket-open' for details.
 135
 136 \(fn WEBSOCKET)")
 137
 138 (websocket-document-function websocket-on-close
 139   "Accessor for websocket on-close callback.
 140 See `websocket-open' for details.
 141
 142 \(fn WEBSOCKET)")
 143
 144 (websocket-document-function websocket-on-error
 145   "Accessor for websocket on-error callback.
 146 See `websocket-open' for details.
 147
 148 \(fn WEBSOCKET)")
 149
 150 (defun websocket-genbytes (nbytes)
 151   "Generate NBYTES random bytes."
 152   (let ((s (make-string nbytes ?\s)))
 153     (dotimes (i nbytes)
 154       (aset s i (random 256)))
 155     s))
 156
 157 (defun websocket-try-callback (websocket-callback callback-type websocket
 158                                                   &rest rest)
 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
 165   ;; changes.
 166   (let ((args rest)
 167         (debug-on-error websocket-callback-debug-on-error))
 168     (push websocket args)
 169     (if websocket-callback-debug-on-error
 170         (condition-case err
 171             (apply (funcall websocket-callback websocket) args)
 172           ((debug error) (funcall (websocket-on-error websocket)
 173                                   websocket callback-type err)))
 174       (condition-case err
 175           (apply (funcall websocket-callback websocket) args)
 176         (error (funcall (websocket-on-error websocket) websocket
 177                         callback-type err))))))
 178
 179 (defun websocket-genkey ()
 180   "Generate a key suitable for the websocket handshake."
 181   (base64-encode-string (websocket-genbytes 16)))
 182
 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)))
 188
 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
 192 power of 2, up to 8.
 193
 194 We support getting frames up to 536870911 bytes (2^29 - 1),
 195 approximately 537M long."
 196   (if (= n 8)
 197     (let* ((32-bit-parts
 198             (bindat-get-field (bindat-unpack '((:val vec 2 u32)) s) :val))
 199            (cval
 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))
 203           cval
 204         (signal 'websocket-unparseable-frame
 205                 "Frame value found too large to parse!")))
 206     ;; n is not 8
 207     (bindat-get-field
 208      (condition-case _
 209          (bindat-unpack
 210           `((:val
 211              ,(cond ((= n 1) 'u8)
 212                     ((= n 2) 'u16)
 213                     ((= n 4) 'u32)
 214                     ;; This is an error with the library,
 215                     ;; not a user-facing, meaningful error.
 216                     (t (error
 217                         "websocket-get-bytes: Unknown N: %s" n)))))
 218           s)
 219        (args-out-of-range (signal 'websocket-unparseable-frame
 220                                   (format "Frame unexpectedly shortly: %s" s))))
 221      :val)))
 222
 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.
 226
 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
 232     ;; this library
 233     (error "websocket-to-bytes: Value %d could not be expressed in %d bytes"
 234            val nbytes))
 235   (if (= nbytes 8)
 236       (progn
 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))
 241                               val
 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])))))
 247     (bindat-pack
 248      `((:val ,(cond ((= nbytes 1) 'u8)
 249                     ((= nbytes 2) 'u16)
 250                     ((= nbytes 4) 'u32)
 251                     ;; Library error, not system error
 252                     (t (error "websocket-to-bytes: Unknown NBYTES: %s" nbytes)))))
 253      `((:val . ,val)))))
 254
 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)
 260           ((= opcode 1) 'text)
 261           ((= opcode 2) 'binary)
 262           ((= opcode 8) 'close)
 263           ((= opcode 9) 'ping)
 264           ((= opcode 10) 'pong))))
 265
 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))
 275           ((= initial-val 126)
 276            (websocket-ensure-length s 3)
 277            (cons (websocket-get-bytes (substring s 1) 2) 3))
 278           (t (cons initial-val 1)))))
 279
 280 (defstruct websocket-frame opcode payload length completep)
 281
 282 (defun websocket-frame-text (frame)
 283   "Given FRAME, return the payload as a utf-8 encoded string."
 284   (assert (websocket-frame-p frame))
 285   (decode-coding-string (websocket-frame-payload frame) 'utf-8))
 286
 287 (defun websocket-mask (key data)
 288   "Using string KEY, mask string DATA according to the RFC.
 289 This is used to both mask and unmask data."
 290   ;; If we don't make the string unibyte here, a string of bytes that should be
 291   ;; interpreted as a unibyte string will instead be interpreted as a multibyte
 292   ;; string of the same length (for example, 6 multibyte chars for 你好 instead
 293   ;; of the correct 6 unibyte chars, which would convert into 2 multibyte
 294   ;; chars).
 295   (string-make-unibyte (apply
 296                         'string
 297                         (loop for b across data
 298                               for i from 0 to (length data)
 299                               collect
 300                               (logxor (websocket-get-bytes (substring key (mod i 4)) 1) b)))))
 301
 302 (defun websocket-ensure-length (s n)
 303   "Ensure the string S has at most N bytes.
 304 Otherwise we throw the error `websocket-incomplete-frame'."
 305   (when (< (length s) n)
 306     (throw 'websocket-incomplete-frame nil)))
 307
 308 (defun websocket-encode-frame (frame should-mask)
 309   "Encode the FRAME struct to the binary representation.
 310 We mask the frame or not, depending on SHOULD-MASK."
 311   (let* ((opcode (websocket-frame-opcode frame))
 312          (payload (websocket-frame-payload frame))
 313          (fin (websocket-frame-completep frame))
 314          (payloadp (and payload
 315                         (memq opcode '(continuation ping pong text binary))))
 316          (mask-key (when should-mask (websocket-genbytes 4))))
 317     (apply 'unibyte-string
 318            (let ((val (append (list
 319                             (logior (cond ((eq opcode 'continuation) 0)
 320                                           ((eq opcode 'text) 1)
 321                                           ((eq opcode 'binary) 2)
 322                                           ((eq opcode 'close) 8)
 323                                           ((eq opcode 'ping) 9)
 324                                           ((eq opcode 'pong) 10))
 325                                     (if fin 128 0)))
 326                            (when payloadp
 327                              (list
 328                               (logior
 329                                (if should-mask 128 0)
 330                                (cond ((< (length payload) 126) (length payload))
 331                                      ((< (length payload) 65536) 126)
 332                                      (t 127)))))
 333                            (when (and payloadp (>= (length payload) 126))
 334                              (append (websocket-to-bytes
 335                                       (length payload)
 336                                       (cond ((< (length payload) 126) 1)
 337                                             ((< (length payload) 65536) 2)
 338                                             (t 8))) nil))
 339                            (when (and payloadp should-mask)
 340                              (append mask-key nil))
 341                            (when payloadp
 342                              (append (if should-mask (websocket-mask mask-key payload)
 343                                        payload)
 344                                      nil)))))
 345              ;; We have to make sure the non-payload data is a full 32-bit frame
 346              (if (= 1 (length val))
 347                  (append val '(0)) val)))))
 348
 349 (defun websocket-read-frame (s)
 350   "Read from string S a `websocket-frame' struct with the contents.
 351 This only gets complete frames.  Partial frames need to wait until
 352 the frame finishes.  If the frame is not completed, return NIL."
 353   (catch 'websocket-incomplete-frame
 354     (websocket-ensure-length s 1)
 355     (let* ((opcode (websocket-get-opcode s))
 356            (fin (logand 128 (websocket-get-bytes s 1)))
 357            (payloadp (memq opcode '(continuation text binary ping pong)))
 358            (payload-len (when payloadp
 359                           (websocket-get-payload-len (substring s 1))))
 360            (maskp (and
 361                    payloadp
 362                    (= 128 (logand 128 (websocket-get-bytes (substring s 1) 1)))))
 363            (payload-start (when payloadp (+ (if maskp 5 1) (cdr payload-len))))
 364            (payload-end (when payloadp (+ payload-start (car payload-len))))
 365            (unmasked-payload (when payloadp
 366                                (websocket-ensure-length s payload-end)
 367                                (substring s payload-start payload-end))))
 368       (make-websocket-frame
 369        :opcode opcode
 370        :payload
 371        (if maskp
 372            (let ((masking-key (substring s (+ 1 (cdr payload-len))
 373                                          (+ 5 (cdr payload-len)))))
 374              (websocket-mask masking-key unmasked-payload))
 375          unmasked-payload)
 376        :length (if payloadp payload-end 1)
 377        :completep (> fin 0)))))
 378
 379 (defun websocket-format-error (err)
 380   "Format an error message like command level does.
 381 ERR should be a cons of error symbol and error data."
 382
 383   ;; Formatting code adapted from `edebug-report-error'
 384   (concat (or (get (car err) 'error-message)
 385               (format "peculiar error (%s)" (car err)))
 386           (when (cdr err)
 387             (format ": %s"
 388                     (mapconcat #'prin1-to-string
 389                                (cdr err) ", ")))))
 390
 391 (defun websocket-default-error-handler (_websocket type err)
 392   "The default error handler used to handle errors in callbacks."
 393   (display-warning 'websocket
 394                    (format "in callback `%S': %s"
 395                            type
 396                            (websocket-format-error err))
 397                    :error))
 398
 399 ;; Error symbols in use by the library
 400 (put 'websocket-unsupported-protocol 'error-conditions
 401      '(error websocket-error websocket-unsupported-protocol))
 402 (put 'websocket-unsupported-protocol 'error-message "Unsupported websocket protocol")
 403 (put 'websocket-wss-needs-emacs-24 'error-conditions
 404      '(error websocket-error websocket-unsupported-protocol
 405              websocket-wss-needs-emacs-24))
 406 (put 'websocket-wss-needs-emacs-24 'error-message
 407      "wss protocol is not supported for Emacs before version 24.")
 408 (put 'websocket-received-error-http-response 'error-conditions
 409      '(error websocket-error websocket-received-error-http-response))
 410 (put 'websocket-received-error-http-response 'error-message
 411      "Error response received from websocket server")
 412 (put 'websocket-invalid-header 'error-conditions
 413      '(error websocket-error websocket-invalid-header))
 414 (put 'websocket-invalid-header 'error-message
 415      "Invalid HTTP header sent")
 416 (put 'websocket-illegal-frame 'error-conditions
 417      '(error websocket-error websocket-illegal-frame))
 418 (put 'websocket-illegal-frame 'error-message
 419      "Cannot send illegal frame to websocket")
 420 (put 'websocket-closed 'error-conditions
 421      '(error websocket-error websocket-closed))
 422 (put 'websocket-closed 'error-message
 423      "Cannot send message to a closed websocket")
 424 (put 'websocket-unparseable-frame 'error-conditions
 425      '(error websocket-error websocket-unparseable-frame))
 426 (put 'websocket-unparseable-frame 'error-message
 427      "Received an unparseable frame")
 428 (put 'websocket-frame-too-large 'error-conditions
 429      '(error websocket-error websocket-frame-too-large))
 430 (put 'websocket-frame-too-large 'error-message
 431      "The frame being sent is too large for this emacs to handle")
 432
 433 (defun websocket-intersect (a b)
 434   "Simple list intersection, should function like Common Lisp's `intersection'."
 435   (let ((result))
 436     (dolist (elem a (nreverse result))
 437       (when (member elem b)
 438         (push elem result)))))
 439
 440 (defun websocket-get-debug-buffer-create (websocket)
 441   "Get or create the buffer corresponding to WEBSOCKET."
 442   (let ((buf (get-buffer-create (format "*websocket %s debug*"
 443                                     (websocket-url websocket)))))
 444     (when (= 0 (buffer-size buf))
 445       (buffer-disable-undo buf))
 446     buf))
 447
 448 (defun websocket-debug (websocket msg &rest args)
 449   "In the WEBSOCKET's debug buffer, send MSG, with format ARGS."
 450   (when websocket-debug
 451     (let ((buf (websocket-get-debug-buffer-create websocket)))
 452       (save-excursion
 453         (with-current-buffer buf
 454           (goto-char (point-max))
 455           (insert "[WS] ")
 456           (insert (apply 'format (append (list msg) args)))
 457           (insert "\n"))))))
 458
 459 (defun websocket-verify-response-code (output)
 460   "Verify that OUTPUT contains a valid HTTP response code.
 461 The only acceptable one to websocket is responce code 101.
 462 A t value will be returned on success, and an error thrown
 463 if not."
 464   (unless (string-match "^HTTP/1.1 \\([[:digit:]]+\\)" output)
 465     (signal 'websocket-invalid-header "Invalid HTTP status line"))
 466   (unless (equal "101" (match-string 1 output))
 467     (signal 'websocket-received-error-http-response
 468             (string-to-number (match-string 1 output))))
 469   t)
 470
 471 (defun websocket-parse-repeated-field (output field)
 472   "From header-containing OUTPUT, parse out the list from a
 473 possibly repeated field."
 474   (let ((pos 0)
 475         (extensions))
 476     (while (and pos
 477                 (string-match (format "\r\n%s: \\(.*\\)\r\n" field)
 478                               output pos))
 479       (when (setq pos (match-end 1))
 480         (setq extensions (append extensions (split-string
 481                                              (match-string 1 output) ", ?")))))
 482     extensions))
 483
 484 (defun websocket-process-frame (websocket frame)
 485   "Using the WEBSOCKET's filter and connection, process the FRAME.
 486 This returns a lambda that should be executed when all frames have
 487 been processed.  If the frame has a payload, the lambda has the frame
 488 passed to the filter slot of WEBSOCKET.  If the frame is a ping,
 489 the lambda has a reply with a pong.  If the frame is a close, the lambda
 490 has connection termination."
 491   (let ((opcode (websocket-frame-opcode frame)))
 492     (lexical-let ((lex-ws websocket)
 493                   (lex-frame frame))
 494       (cond ((memq opcode '(continuation text binary))
 495              (lambda () (websocket-try-callback 'websocket-on-message 'on-message
 496                                            lex-ws lex-frame)))
 497             ((eq opcode 'ping)
 498              (lambda () (websocket-send lex-ws
 499                                         (make-websocket-frame
 500                                          :opcode 'pong
 501                                          :payload (websocket-frame-payload lex-frame)
 502                                          :completep t))))
 503             ((eq opcode 'close)
 504              (lambda () (delete-process (websocket-conn lex-ws))))
 505             (t (lambda ()))))))
 506
 507 (defun websocket-process-input-on-open-ws (websocket text)
 508   "This handles input processing for both the client and server filters."
 509   (let ((current-frame)
 510         (processing-queue)
 511         (start-point 0))
 512     (while (setq current-frame (websocket-read-frame
 513                                 (substring text start-point)))
 514       (push (websocket-process-frame websocket current-frame) processing-queue)
 515       (incf start-point (websocket-frame-length current-frame)))
 516     (when (> (length text) start-point)
 517       (setf (websocket-inflight-input websocket)
 518             (substring text start-point)))
 519     (dolist (to-process (nreverse processing-queue))
 520       (funcall to-process))))
 521
 522 (defun websocket-send-text (websocket text)
 523   "To the WEBSOCKET, send TEXT as a complete frame."
 524   (websocket-send
 525    websocket
 526    (make-websocket-frame :opcode 'text
 527                          :payload (encode-coding-string
 528                                    text 'raw-text)
 529                          :completep t)))
 530
 531 (defun websocket-check (frame)
 532   "Check FRAME for correctness, returning true if correct."
 533   (or
 534    ;; Text, binary, and continuation frames need payloads
 535    (and (memq (websocket-frame-opcode frame) '(text binary continuation))
 536         (websocket-frame-payload frame))
 537    ;; Pings and pongs may optionally have them
 538    (memq (websocket-frame-opcode frame) '(ping pong))
 539    ;; And close shouldn't have any payload, and should always be complete.
 540    (and (eq (websocket-frame-opcode frame) 'close)
 541         (not (websocket-frame-payload frame))
 542         (websocket-frame-completep frame))))
 543
 544 (defun websocket-send (websocket frame)
 545   "To the WEBSOCKET server, send the FRAME.
 546 This will raise an error if the frame is illegal.
 547
 548 The error signaled may be of type `websocket-illegal-frame' if
 549 the frame is malformed in some way, also having the condition
 550 type of `websocket-error'.  The data associated with the signal
 551 is the frame being sent.
 552
 553 If the websocket is closed a signal `websocket-closed' is sent,
 554 also with `websocket-error' condition.  The data in the signal is
 555 also the frame.
 556
 557 The frame may be too large for this buid of Emacs, in which case
 558 `websocket-frame-too-large' is returned, with the data of the
 559 size of the frame which was too large to process.  This also has
 560 the `websocket-error' condition."
 561   (unless (websocket-check frame)
 562     (signal 'websocket-illegal-frame frame))
 563   (websocket-debug websocket "Sending frame, opcode: %s payload: %s"
 564                    (websocket-frame-opcode frame)
 565                    (websocket-frame-payload frame))
 566   (websocket-ensure-connected websocket)
 567   (unless (websocket-openp websocket)
 568     (signal 'websocket-closed frame))
 569   (process-send-string (websocket-conn websocket)
 570                        ;; We mask only when we're a client, following the spec.
 571                        (websocket-encode-frame frame (not (websocket-server-p websocket)))))
 572
 573 (defun websocket-openp (websocket)
 574   "Check WEBSOCKET and return non-nil if it is open, and either
 575 connecting or open."
 576   (and websocket
 577        (not (eq 'close (websocket-ready-state websocket)))
 578        (member (process-status (websocket-conn websocket)) '(open run))))
 579
 580 (defun websocket-close (websocket)
 581   "Close WEBSOCKET and erase all the old websocket data."
 582   (websocket-debug websocket "Closing websocket")
 583   (websocket-try-callback 'websocket-on-close 'on-close websocket)
 584   (when (websocket-openp websocket)
 585     (websocket-send websocket
 586                     (make-websocket-frame :opcode 'close
 587                                           :completep t))
 588     (setf (websocket-ready-state websocket) 'closed))
 589   (delete-process (websocket-conn websocket)))
 590
 591 (defun websocket-ensure-connected (websocket)
 592   "If the WEBSOCKET connection is closed, open it."
 593   (unless (and (websocket-conn websocket)
 594                (ecase (process-status (websocket-conn websocket))
 595                  ((run open listen) t)
 596                  ((stop exit signal closed connect failed nil) nil)))
 597     (websocket-close websocket)
 598     (websocket-open (websocket-url websocket)
 599                     :protocols (websocket-protocols websocket)
 600                     :extensions (websocket-extensions websocket)
 601                     :on-open (websocket-on-open websocket)
 602                     :on-message (websocket-on-message websocket)
 603                     :on-close (websocket-on-close websocket)
 604                     :on-error (websocket-on-error websocket))))
 605
 606 ;;;;;;;;;;;;;;;;;;;;;;
 607 ;; Websocket client ;;
 608 ;;;;;;;;;;;;;;;;;;;;;;
 609
 610 (defun* websocket-open (url &key protocols extensions (on-open 'identity)
 611                             (on-message (lambda (_w _f))) (on-close 'identity)
 612                             (on-error 'websocket-default-error-handler))
 613   "Open a websocket connection to URL, returning the `websocket' struct.
 614 The PROTOCOL argument is optional, and setting it will declare to
 615 the server that this client supports the protocols in the list
 616 given.  We will require that the server also has to support that
 617 protocols.
 618
 619 Similar logic applies to EXTENSIONS, which is a list of conses,
 620 the car of which is a string naming the extension, and the cdr of
 621 which is the list of parameter strings to use for that extension.
 622 The parameter strings are of the form \"key=value\" or \"value\".
 623 EXTENSIONS can be NIL if none are in use.  An example value would
 624 be (\"deflate-stream\" . (\"mux\" \"max-channels=4\")).
 625
 626 Cookies that are set via `url-cookie-store' will be used during
 627 communication with the server, and cookies received from the
 628 server will be stored in the same cookie storage that the
 629 `url-cookie' package uses.
 630
 631 Optionally you can specify
 632 ON-OPEN, ON-MESSAGE and ON-CLOSE callbacks as well.
 633
 634 The ON-OPEN callback is called after the connection is
 635 established with the websocket as the only argument.  The return
 636 value is unused.
 637
 638 The ON-MESSAGE callback is called after receiving a frame, and is
 639 called with the websocket as the first argument and
 640 `websocket-frame' struct as the second.  The return value is
 641 unused.
 642
 643 The ON-CLOSE callback is called after the connection is closed, or
 644 failed to open.  It is called with the websocket as the only
 645 argument, and the return value is unused.
 646
 647 The ON-ERROR callback is called when any of the other callbacks
 648 have an error.  It takes the websocket as the first argument, and
 649 a symbol as the second argument either `on-open', `on-message',
 650 or `on-close', and the error as the third argument. Do NOT
 651 rethrow the error, or else you may miss some websocket messages.
 652 You similarly must not generate any other errors in this method.
 653 If you want to debug errors, set
 654 `websocket-callback-debug-on-error' to t, but this also can be
 655 dangerous is the debugger is quit out of.  If not specified,
 656 `websocket-default-error-handler' is used.
 657
 658 For each of these event handlers, the client code can store
 659 arbitrary data in the `client-data' slot in the returned
 660 websocket.
 661
 662 The following errors might be thrown in this method or in
 663 websocket processing, all of them having the error-condition
 664 `websocket-error' in addition to their own symbol:
 665
 666 `websocket-unsupported-protocol': Data in the error signal is the
 667 protocol that is unsupported.  For example, giving a URL starting
 668 with http by mistake raises this error.
 669
 670 `websocket-wss-needs-emacs-24': Trying to connect wss protocol
 671 using Emacs < 24 raises this error.  You can catch this error
 672 also by `websocket-unsupported-protocol'.
 673
 674 `websocket-received-error-http-response': Data in the error
 675 signal is the integer error number.
 676
 677 `websocket-invalid-header': Data in the error is a string
 678 describing the invalid header received from the server.
 679
 680 `websocket-unparseable-frame': Data in the error is a string
 681 describing the problem with the frame.
 682 "
 683   (let* ((name (format "websocket to %s" url))
 684          (url-struct (url-generic-parse-url url))
 685          (key (websocket-genkey))
 686          (coding-system-for-read 'binary)
 687          (coding-system-for-write 'binary)
 688          (conn (if (member (url-type url-struct) '("ws" "wss"))
 689                    (let* ((type (if (equal (url-type url-struct) "ws")
 690                                     'plain 'tls))
 691                           (port (if (= 0 (url-port url-struct))
 692                                     (if (eq type 'tls) 443 80)
 693                                   (url-port url-struct)))
 694                           (host (url-host url-struct)))
 695                        (if (eq type 'plain)
 696                            (make-network-process :name name :buffer nil :host host
 697                                                  :service port :nowait nil)
 698                          (condition-case-unless-debug nil
 699                              (open-network-stream name nil host port :type type :nowait nil)
 700                            (wrong-number-of-arguments
 701                             (signal 'websocket-wss-needs-emacs-24 "wss")))))
 702                  (signal 'websocket-unsupported-protocol (url-type url-struct))))
 703          (websocket (websocket-inner-create
 704                      :conn conn
 705                      :url url
 706                      :on-open on-open
 707                      :on-message on-message
 708                      :on-close on-close
 709                      :on-error on-error
 710                      :protocols protocols
 711                      :extensions (mapcar 'car extensions)
 712                      :accept-string
 713                      (websocket-calculate-accept key))))
 714     (unless conn (error "Could not establish the websocket connection to %s" url))
 715     (process-put conn :websocket websocket)
 716     (set-process-filter conn
 717                         (lambda (process output)
 718                           (let ((websocket (process-get process :websocket)))
 719                             (websocket-outer-filter websocket output))))
 720     (set-process-sentinel
 721      conn
 722      (lambda (process change)
 723        (let ((websocket (process-get process :websocket)))
 724          (websocket-debug websocket "State change to %s" change)
 725          (when (and
 726                 (member (process-status process) '(closed failed exit signal))
 727                 (not (eq 'closed (websocket-ready-state websocket))))
 728            (websocket-try-callback 'websocket-on-close 'on-close websocket)))))
 729     (set-process-query-on-exit-flag conn nil)
 730     (process-send-string conn
 731                          (format "GET %s HTTP/1.1\r\n"
 732                                  (let ((path (url-filename url-struct)))
 733                                    (if (> (length path) 0) path "/"))))
 734     (websocket-debug websocket "Sending handshake, key: %s, acceptance: %s"
 735                      key (websocket-accept-string websocket))
 736     (process-send-string conn
 737                          (websocket-create-headers url key protocols extensions))
 738     (websocket-debug websocket "Websocket opened")
 739     websocket))
 740
 741 (defun websocket-process-headers (url headers)
 742   "On opening URL, process the HEADERS sent from the server."
 743   (when (string-match "Set-Cookie: \(.*\)\r\n" headers)
 744     ;; The url-current-object is assumed to be set by
 745     ;; url-cookie-handle-set-cookie.
 746     (let ((url-current-object (url-generic-parse-url url)))
 747       (url-cookie-handle-set-cookie (match-string 1 headers)))))
 748
 749 (defun websocket-outer-filter (websocket output)
 750   "Filter the WEBSOCKET server's OUTPUT.
 751 This will parse headers and process frames repeatedly until there
 752 is no more output or the connection closes.  If the websocket
 753 connection is invalid, the connection will be closed."
 754   (websocket-debug websocket "Received: %s" output)
 755   (let ((start-point)
 756         (text (concat (websocket-inflight-input websocket) output))
 757         (header-end-pos))
 758     (setf (websocket-inflight-input websocket) nil)
 759     ;; If we've received the complete header, check to see if we've
 760     ;; received the desired handshake.
 761     (when (and (eq 'connecting (websocket-ready-state websocket)))
 762       (if (and (setq header-end-pos (string-match "\r\n\r\n" text))
 763                (setq start-point (+ 4 header-end-pos)))
 764           (progn
 765             (condition-case err
 766                 (progn
 767                   (websocket-verify-response-code text)
 768                   (websocket-verify-headers websocket text)
 769                   (websocket-process-headers (websocket-url websocket) text))
 770               (error
 771                (websocket-close websocket)
 772                (signal (car err) (cdr err))))
 773             (setf (websocket-ready-state websocket) 'open)
 774             (websocket-try-callback 'websocket-on-open 'on-open websocket))
 775         (setf (websocket-inflight-input websocket) text)))
 776     (when (eq 'open (websocket-ready-state websocket))
 777       (websocket-process-input-on-open-ws
 778        websocket (substring text (or start-point 0))))))
 779
 780 (defun websocket-verify-headers (websocket output)
 781   "Based on WEBSOCKET's data, ensure the headers in OUTPUT are valid.
 782 The output is assumed to have complete headers.  This function
 783 will either return t or call `error'.  This has the side-effect
 784 of populating the list of server extensions to WEBSOCKET."
 785   (let ((accept-string
 786          (concat "Sec-WebSocket-Accept: " (websocket-accept-string websocket))))
 787     (websocket-debug websocket "Checking for accept header: %s" accept-string)
 788     (unless (string-match (regexp-quote accept-string) output)
 789       (signal 'websocket-invalid-header
 790               "Incorrect handshake from websocket: is this really a websocket connection?")))
 791   (let ((case-fold-search t))
 792     (websocket-debug websocket "Checking for upgrade header")
 793     (unless (string-match "\r\nUpgrade: websocket\r\n" output)
 794       (signal 'websocket-invalid-header
 795               "No 'Upgrade: websocket' header found"))
 796     (websocket-debug websocket "Checking for connection header")
 797     (unless (string-match "\r\nConnection: upgrade\r\n" output)
 798       (signal 'websocket-invalid-header
 799               "No 'Connection: upgrade' header found"))
 800     (when (websocket-protocols websocket)
 801       (dolist (protocol (websocket-protocols websocket))
 802         (websocket-debug websocket "Checking for protocol match: %s"
 803                          protocol)
 804         (let ((protocols
 805                (if (string-match (format "\r\nSec-Websocket-Protocol: %s\r\n"
 806                                          protocol)
 807                                  output)
 808                    (list protocol)
 809                  (signal 'websocket-invalid-header
 810                          "Incorrect or missing protocol returned by the server."))))
 811           (setf (websocket-negotiated-protocols websocket) protocols))))
 812     (let* ((extensions (websocket-parse-repeated-field
 813                         output
 814                         "Sec-WebSocket-Extensions"))
 815            (extra-extensions))
 816       (dolist (ext extensions)
 817         (let ((x (first (split-string ext "; ?"))))
 818           (unless (or (member x (websocket-extensions websocket))
 819                       (member x extra-extensions))
 820             (push x extra-extensions))))
 821       (when extra-extensions
 822         (signal 'websocket-invalid-header
 823                 (format "Non-requested extensions returned by server: %S"
 824                         extra-extensions)))
 825       (setf (websocket-negotiated-extensions websocket) extensions)))
 826   t)
 827
 828 ;;;;;;;;;;;;;;;;;;;;;;
 829 ;; Websocket server ;;
 830 ;;;;;;;;;;;;;;;;;;;;;;
 831
 832 (defvar websocket-server-websockets nil
 833   "A list of current websockets live on any server.")
 834
 835 (defun* websocket-server (port &rest plist)
 836   "Open a websocket server on PORT.
 837 If the plist contains a `:host' HOST pair, this value will be
 838 used to configure the addresses the socket listens on. The symbol
 839 `local' specifies the local host. If unspecified or nil, the
 840 socket will listen on all addresses.
 841
 842 This also takes a plist of callbacks: `:on-open', `:on-message',
 843 `:on-close' and `:on-error', which operate exactly as documented
 844 in the websocket client function `websocket-open'.  Returns the
 845 connection, which should be kept in order to pass to
 846 `websocket-server-close'."
 847   (let* ((conn (make-network-process
 848                 :name (format "websocket server on port %s" port)
 849                 :server t
 850                 :family 'ipv4
 851                 :noquery t
 852                 :filter 'websocket-server-filter
 853                 :log 'websocket-server-accept
 854                 :filter-multibyte nil
 855                 :plist plist
 856                 :host (plist-get plist :host)
 857                 :service port)))
 858     conn))
 859
 860 (defun websocket-server-close (conn)
 861   "Closes the websocket, as well as all open websockets for this server."
 862   (let ((to-delete))
 863     (dolist (ws websocket-server-websockets)
 864       (when (eq (websocket-server-conn ws) conn)
 865         (if (eq (websocket-ready-state ws) 'closed)
 866             (unless (member ws to-delete)
 867               (push ws to-delete))
 868           (websocket-close ws))))
 869     (dolist (ws to-delete)
 870       (setq websocket-server-websockets (remove ws websocket-server-websockets))))
 871   (delete-process conn))
 872
 873 (defun websocket-server-accept (server client _message)
 874   "Accept a new websocket connection from a client."
 875   (let ((ws (websocket-inner-create
 876              :server-conn server
 877              :conn client
 878              :url client
 879              :server-p t
 880              :on-open (or (process-get server :on-open) 'identity)
 881              :on-message (or (process-get server :on-message) (lambda (_ws _frame)))
 882              :on-close (lexical-let ((user-method
 883                                       (or (process-get server :on-close) 'identity)))
 884                          (lambda (ws)
 885                            (setq websocket-server-websockets
 886                                  (remove ws websocket-server-websockets))
 887                            (funcall user-method ws)))
 888              :on-error (or (process-get server :on-error)
 889                            'websocket-default-error-handler)
 890              :protocols (process-get server :protocol)
 891              :extensions (mapcar 'car (process-get server :extensions)))))
 892     (unless (member ws websocket-server-websockets)
 893       (push ws websocket-server-websockets))
 894     (process-put client :websocket ws)
 895     (set-process-coding-system client 'binary 'binary)
 896     (set-process-sentinel client
 897      (lambda (process change)
 898        (let ((websocket (process-get process :websocket)))
 899          (websocket-debug websocket "State change to %s" change)
 900          (when (and
 901                 (member (process-status process) '(closed failed exit signal))
 902                 (not (eq 'closed (websocket-ready-state websocket))))
 903            (websocket-try-callback 'websocket-on-close 'on-close websocket)))))))
 904
 905 (defun websocket-create-headers (url key protocol extensions)
 906   "Create connections headers for the given URL, KEY, PROTOCOL and EXTENSIONS.
 907 These are defined as in `websocket-open'."
 908   (let* ((parsed-url (url-generic-parse-url url))
 909          (host-port (if (url-port-if-non-default parsed-url)
 910                         (format "%s:%s" (url-host parsed-url) (url-port parsed-url))
 911                       (url-host parsed-url)))
 912          (cookie-header (url-cookie-generate-header-lines
 913                          host-port (car (url-path-and-query parsed-url))
 914                          (equal (url-type parsed-url) "wss"))))
 915     (format (concat "Host: %s\r\n"
 916                     "Upgrade: websocket\r\n"
 917                     "Connection: Upgrade\r\n"
 918                     "Sec-WebSocket-Key: %s\r\n"
 919                     "Sec-WebSocket-Version: 13\r\n"
 920                     (when protocol
 921                       (concat
 922                        (mapconcat
 923                         (lambda (protocol)
 924                           (format "Sec-WebSocket-Protocol: %s" protocol))
 925                         protocol "\r\n")
 926                        "\r\n"))
 927                     (when extensions
 928                       (format "Sec-WebSocket-Extensions: %s\r\n"
 929                               (mapconcat
 930                                (lambda (ext)
 931                                  (concat
 932                                   (car ext)
 933                                   (when (cdr ext) "; ")
 934                                   (when (cdr ext)
 935                                     (mapconcat 'identity (cdr ext) "; "))))
 936                                extensions ", ")))
 937                     (when cookie-header cookie-header)
 938                     "\r\n")
 939             host-port
 940             key
 941             protocol)))
 942
 943 (defun websocket-get-server-response (websocket client-protocols client-extensions)
 944   "Get the websocket response from client WEBSOCKET."
 945   (let ((separator "\r\n"))
 946       (concat "HTTP/1.1 101 Switching Protocols" separator
 947               "Upgrade: websocket" separator
 948               "Connection: Upgrade" separator
 949               "Sec-WebSocket-Accept: "
 950               (websocket-accept-string websocket) separator
 951               (let ((protocols
 952                          (websocket-intersect client-protocols
 953                                               (websocket-protocols websocket))))
 954                     (when protocols
 955                       (concat
 956                        (mapconcat
 957                         (lambda (protocol) (format "Sec-WebSocket-Protocol: %s"
 958                                               protocol)) protocols separator)
 959                        separator)))
 960               (let ((extensions (websocket-intersect
 961                                    client-extensions
 962                                    (websocket-extensions websocket))))
 963                   (when extensions
 964                     (concat
 965                      (mapconcat
 966                       (lambda (extension) (format "Sec-Websocket-Extensions: %s"
 967                                              extension)) extensions separator)
 968                      separator)))
 969               separator)))
 970
 971 (defun websocket-server-filter (process output)
 972   "This acts on all OUTPUT from websocket clients PROCESS."
 973   (let* ((ws (process-get process :websocket))
 974          (text (concat (websocket-inflight-input ws) output)))
 975     (setf (websocket-inflight-input ws) nil)
 976     (cond ((eq (websocket-ready-state ws) 'connecting)
 977            ;; check for connection string
 978            (let ((end-of-header-pos
 979                   (let ((pos (string-match "\r\n\r\n" text)))
 980                     (when pos (+ 4 pos)))))
 981                (if end-of-header-pos
 982                    (progn
 983                      (let ((header-info (websocket-verify-client-headers text)))
 984                        (if header-info
 985                            (progn (setf (websocket-accept-string ws)
 986                                         (websocket-calculate-accept
 987                                          (plist-get header-info :key)))
 988                                   (process-send-string
 989                                    process
 990                                    (websocket-get-server-response
 991                                     ws (plist-get header-info :protocols)
 992                                     (plist-get header-info :extensions)))
 993                                   (setf (websocket-ready-state ws) 'open)
 994                                   (websocket-try-callback 'websocket-on-open
 995                                                           'on-open ws))
 996                          (message "Invalid client headers found in: %s" output)
 997                          (process-send-string process "HTTP/1.1 400 Bad Request\r\n\r\n")
 998                          (websocket-close ws)))
 999                      (when (> (length text) (+ 1 end-of-header-pos))
1000                        (websocket-server-filter process (substring
1001                                                            text
1002                                                            end-of-header-pos))))
1003                  (setf (websocket-inflight-input ws) text))))
1004           ((eq (websocket-ready-state ws) 'open)
1005            (websocket-process-input-on-open-ws ws text))
1006           ((eq (websocket-ready-state ws) 'closed)
1007            (message "WARNING: Should not have received further input on closed websocket")))))
1008
1009 (defun websocket-verify-client-headers (output)
1010   "Verify the headers from the WEBSOCKET client connection in OUTPUT.
1011 Unlike `websocket-verify-headers', this is a quieter routine.  We
1012 don't want to error due to a bad client, so we just print out
1013 messages and a plist containing `:key', the websocket key,
1014 `:protocols' and `:extensions'."
1015   (block nil
1016     (let ((case-fold-search t)
1017           (plist))
1018       (unless (string-match "HTTP/1.1" output)
1019         (message "Websocket client connection: HTTP/1.1 not found")
1020         (return nil))
1021       (unless (string-match "^Host: " output)
1022         (message "Websocket client connection: Host header not found")
1023         (return nil))
1024       (unless (string-match "^Upgrade: websocket\r\n" output)
1025         (message "Websocket client connection: Upgrade: websocket not found")
1026         (return nil))
1027       (if (string-match "^Sec-WebSocket-Key: \\([[:graph:]]+\\)\r\n" output)
1028           (setq plist (plist-put plist :key (match-string 1 output)))
1029         (message "Websocket client connect: No key sent")
1030         (return nil))
1031       (unless (string-match "^Sec-WebSocket-Version: 13" output)
1032         (message "Websocket client connect: Websocket version 13 not found")
1033         (return nil))
1034       (when (string-match "^Sec-WebSocket-Protocol:" output)
1035         (setq plist (plist-put plist :protocols (websocket-parse-repeated-field
1036                                                  output
1037                                                  "Sec-Websocket-Protocol"))))
1038       (when (string-match "^Sec-WebSocket-Extensions:" output)
1039         (setq plist (plist-put plist :extensions (websocket-parse-repeated-field
1040                                                   output
1041                                                   "Sec-Websocket-Extensions"))))
1042       plist)))
1043
1044 (provide 'websocket)
1045
1046 ;;; websocket.el ends here