8sync/systems/websocket/frame.scm

   1 ;;; guile-websocket --- WebSocket client/server
   2 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
   3 ;;; Copyright © 2019 Rutger van Beusekom <rutger.van.beusekom@gmail.com>
   4 ;;;
   5 ;;; This file is part of guile-websocket.
   6 ;;;
   7 ;;; Guile-websocket is free software; you can redistribute it and/or modify
   8 ;;; it under the terms of the GNU Lesser General Public License as
   9 ;;; published by the Free Software Foundation; either version 3 of the
  10 ;;; License, or (at your option) any later version.
  11 ;;;
  12 ;;; Guile-websocket is distributed in the hope that it will be useful,
  13 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 ;;; Lesser General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU Lesser General Public
  18 ;;; License along with guile-websocket.  If not, see
  19 ;;; <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22 ;;
  23 ;; WebSocket frame abstraction.
  24 ;;
  25 ;;; Code:
  26
  27 (define-module (8sync systems websocket frame)
  28   #:use-module (rnrs bytevectors)
  29   #:use-module (rnrs io ports)
  30   #:use-module (ice-9 format)
  31   #:use-module (ice-9 match)
  32   #:use-module (ice-9 rdelim)
  33   #:use-module (srfi srfi-1)
  34   #:use-module (srfi srfi-9)
  35   #:use-module (srfi srfi-9 gnu)
  36   #:use-module (srfi srfi-26)
  37   #:export (make-frame
  38             frame?
  39             frame-final?
  40             frame-type
  41             frame-masking-key
  42             frame-data
  43
  44             make-ping-frame
  45             make-pong-frame
  46             make-close-frame
  47             make-text-frame
  48             make-binary-frame
  49
  50             continuation-frame?
  51             text-frame?
  52             binary-frame?
  53             close-frame?
  54             ping-frame?
  55             pong-frame?
  56             fragment-frame?
  57             first-fragment-frame?
  58             final-fragment-frame?
  59             control-frame?
  60             data-frame?
  61
  62             frame-length
  63             frame-concatenate
  64             text-frame->string
  65             text-frames->string
  66
  67             read-frame
  68             write-frame))
  69
  70 ;;;
  71 ;;; WebSocket frames
  72 ;;;
  73
  74 (define-record-type <frame>
  75   (make-frame final? type masking-key data)
  76   frame?
  77   (final? frame-final?)
  78   (type frame-type)
  79   (masking-key frame-masking-key)
  80   (data frame-data))
  81
  82 (define (display-frame frame port)
  83   (format port "#<frame final?: ~a type: ~a masking-key: ~a length: ~d>"
  84           (frame-final? frame)
  85           (frame-type frame)
  86           (frame-masking-key frame)
  87           (frame-length frame)))
  88
  89 (set-record-type-printer! <frame> display-frame)
  90
  91 (define* (make-ping-frame bv #:optional masking-key)
  92   "Return a \"ping\" control frame containing the contents of the
  93 bytevector BV, masked with MASKING-KEY.  By default, the data is
  94 unmasked."
  95   (make-frame #t 'ping masking-key bv))
  96
  97 (define* (make-pong-frame bv #:optional masking-key)
  98   "Return a \"pong\" control frame containing the contents of the
  99 bytevector BV, masked with MASKING-KEY.  By default, the data is
 100 unmasked."
 101   (make-frame #t 'pong masking-key bv))
 102
 103 (define* (make-close-frame bv #:optional masking-key)
 104   "Return a \"close\" control frame containing the contents of the
 105 bytevector BV, masked with MASKING-KEY.  By default, the data is
 106 unmasked."
 107   (make-frame #t 'close masking-key bv))
 108
 109 (define* (make-text-frame text #:optional masking-key)
 110   "Return a text data frame containing the string TEXT, masked with MASKING-KEY.
 111 By default, the text is unmasked."
 112   (make-frame #t 'text masking-key (string->utf8 text)))
 113
 114 (define* (make-binary-frame bv #:optional masking-key)
 115   "Return a binary data frame containing the contents of the
 116 bytevector BV, masked with MASKING-KEY.  By default, the data is
 117 unmasked."
 118   (make-frame #t 'binary masking-key bv))
 119
 120 (define (continuation-frame? frame)
 121   "Return #t if FRAME is a continuation frame."
 122   (eq? (frame-type frame) 'continuation))
 123
 124 (define (text-frame? frame)
 125   "Return #t if FRAME is a text frame."
 126   (eq? (frame-type frame) 'text))
 127
 128 (define (binary-frame? frame)
 129   "Return #t if FRAME is a binary frame."
 130   (eq? (frame-type frame) 'binary))
 131
 132 (define (close-frame? frame)
 133   "Return #t if FRAME is a close frame."
 134   (eq? (frame-type frame) 'close))
 135
 136 (define (ping-frame? frame)
 137   "Return #t if FRAME is a ping frame."
 138   (eq? (frame-type frame) 'ping))
 139
 140 (define (pong-frame? frame)
 141   "Return #t if FRAME is a pong frame."
 142   (eq? (frame-type frame) 'pong))
 143
 144 ;; See section 5.4 - Fragmentation
 145 (define (fragment-frame? frame)
 146   "Return #t if FRAME is an incomplete message."
 147   (or (continuation-frame? frame)
 148       (not (frame-final? frame))))
 149
 150 (define (first-fragment-frame? frame)
 151   "Return #t if FRAME is the first piece of a fragmented message."
 152   (and (not (frame-final? frame))
 153        (data-frame? frame)))
 154
 155 (define (final-fragment-frame? frame)
 156   "Return #t if FRAME is the final piece of a fragmented message."
 157   (and (frame-final? frame)
 158        (continuation-frame? frame)))
 159
 160 ;; See section 5.5 - Control Frames
 161 (define (control-frame? frame)
 162   "Return #t if FRAME is a control frame."
 163   (or (close-frame? frame)
 164       (ping-frame? frame)
 165       (pong-frame? frame)))
 166
 167 ;; See section 5.6 - Data Frames
 168 (define (data-frame? frame)
 169   "Return #t if FRAME is a data frame."
 170   (or (text-frame? frame)
 171       (binary-frame? frame)))
 172
 173 (define (frame-length frame)
 174   "Return the length of the data bytevector in FRAME."
 175   (bytevector-length (frame-data frame)))
 176
 177 (define (text-frame->string frame)
 178   "Convert FRAME, an unfragmented text frame, into a string."
 179   (utf8->string (frame-data frame)))
 180
 181 (define (frame-concatenate frames)
 182   "Concatenate the data in FRAMES, a list of fragmented frames, into a
 183 single bytevector."
 184   (let ((bv (make-bytevector (reduce + 0 (map frame-length frames)))))
 185     (let loop ((frames frames)
 186                (offset 0))
 187       (match frames
 188         (() bv)
 189         ((frame . rest)
 190          (let ((length (frame-length frame)))
 191            (bytevector-copy! (frame-data frame) 0 bv offset length)
 192            (loop rest (+ offset length))))))))
 193
 194 (define (text-frames->string frames)
 195   "Convert FRAMES, a list of fragmented text frames, into a single
 196 concatenated string."
 197   (utf8->string (frame-concatenate frames)))
 198
 199 (define (call-with-input-bytevector bv proc)
 200   "Call PROC with one argument: an open input port that reads from the
 201 bytevector BV."
 202   (let ((port (open-bytevector-input-port bv)))
 203     (dynamic-wind
 204       (const #t)
 205       (lambda ()
 206         (proc port))
 207       (lambda ()
 208         (close-port port)))))
 209
 210 (define (close-frame->status frame)
 211   "Convert FRAME, a close frame, into a pair.  The \"car\" of the pair
 212 is a positive integer status code, and the \"cdr\" is a string
 213 containing the explanation, if present."
 214   (define (read-status-code)
 215     (match (bytevector-sint-ref (frame-data frame) 0 (endianness big) 2)
 216       ;; See section 7.4
 217       ((and (or 1005 1006 1015) status)
 218        (websocket-error "invalid use of reserved status code: " status))
 219       (status status)))
 220
 221   (let ((length (frame-length frame)))
 222     (cond
 223      ((zero? length) ; unspecified closing status
 224       '(1005 . ""))
 225      ((= length 2) ; status code only
 226       (cons (read-status-code) ""))
 227      (else ; status + reason
 228       (cons (read-status-code)
 229             (call-with-input-bytevector (frame-data frame)
 230               (lambda (port)
 231                 ;; Throw away the status code.
 232                 (get-u8 port)
 233                 (get-u8 port)
 234                 ;; Now read the reason.
 235                 (read-string port))))))))
 236
 237 \f
 238 ;;;
 239 ;;; Frame reader
 240 ;;;
 241
 242 ;; See section 5.3 - Client-to-Server Masking
 243 (define (mask-bytevector! bv masking-key)
 244   "Apply the WebSocket masking algorithm to the bytevector BV using
 245 MASKING-KEY."
 246   (let loop ((i 0))
 247     (when (< i (bytevector-length bv))
 248       (let ((masked (logxor (u8vector-ref bv i)
 249                             (u8vector-ref masking-key (modulo i 4)))))
 250         (u8vector-set! bv i masked)
 251         (loop (1+ i))))))
 252
 253 (define (websocket-error message . args)
 254   (apply error message args))
 255
 256 ;; See section 5.2 - Base Framing Protocol
 257 (define (read-frame port)
 258   (define (opcode->frame-type opcode)
 259     (match opcode
 260       (#x0 'continuation)
 261       (#x1 'text)
 262       (#x2 'binary)
 263       (#x8 'close)
 264       (#x9 'ping)
 265       (#xA 'pong)
 266       (else (websocket-error "invalid opcode: " opcode))))
 267
 268   (define (control-frame? type)
 269     (memq type '(close ping pong)))
 270
 271   (define (parse-fin-bit octet)
 272     ;; Test the first bit of the octet.
 273     (not (zero? (logand #x80 octet))))
 274
 275   (define (parse-opcode octet final?)
 276     ;; The opcode is stored in the least significant nibble of the
 277     ;; octet.
 278     (let ((type (opcode->frame-type (logand #x0f octet))))
 279       ;; Section 5.5 specifies that control frames must not be
 280       ;; fragmented.
 281       (when (and (not final?) (control-frame? type))
 282         (websocket-error "fragmented control frame: " type))
 283       type))
 284
 285   (define (parse-mask-bit octet)
 286     (not (zero? (logand #x80 octet))))
 287
 288   (define (parse-length octet)
 289     ;; For lengths <= 125, the frame length is encoded in the last 7
 290     ;; bits of the octet.  If this number is 126, then the true length
 291     ;; is encoded in the following 16 bits.  If the number is 127,
 292     ;; then the true length is encoded in the following 64 bits.
 293     (match (logand #x7f octet)
 294       (126
 295        (bytevector-u16-ref (get-bytevector-n port 2) 0 (endianness big)))
 296       (127
 297        (bytevector-u64-ref (get-bytevector-n port 8) 0 (endianness big)))
 298       (length length)))
 299
 300   (define (parse-masking-key)
 301     ;; Masking keys are always 32 bits.
 302     (get-bytevector-n port 4))
 303
 304   (define (read-data type masking-key length)
 305     ;; Section 5.5 specifies that control frame bodies may not exceed
 306     ;; 125 bytes.
 307     (when (and (> length 125)
 308                (control-frame? type))
 309       (websocket-error "control frame too large: " type length))
 310
 311     (let ((bv (get-bytevector-n port length)))
 312       (when masking-key
 313         (unless (eof-object? bv)
 314           (mask-bytevector! bv masking-key)))
 315       bv))
 316
 317   (let* ((type-byte (get-u8 port))
 318          (length-byte (get-u8 port))
 319          (final? (parse-fin-bit type-byte))
 320          (type (parse-opcode type-byte final?))
 321          (mask? (parse-mask-bit length-byte))
 322          (length (parse-length length-byte))
 323          (masking-key (and mask? (parse-masking-key)))
 324          (data (read-data type masking-key length)))
 325     (make-frame final? type masking-key data)))
 326
 327 \f
 328 ;;;
 329 ;;; Frame writer
 330 ;;;
 331
 332 (define* (write-frame frame #:optional (port (current-output-port)))
 333   ;; Packs an unsigned integer into a bytevector in network byte
 334   ;; order.
 335   (define (uint->bytevector n size)
 336     (uint-list->bytevector (list n) (endianness big) size))
 337
 338   (define (masked-data mask data)
 339     (let ((bv (bytevector-copy data)))
 340       (mask-bytevector! bv mask)
 341       bv))
 342
 343   (let ((length (frame-length frame))
 344         (mask   (frame-masking-key frame))
 345         (data   (frame-data frame)))
 346     ;; Write FIN bit and opcode.
 347     (put-u8 port
 348             (logior (if (frame-final? frame) #x80 #x00)
 349                     (match (frame-type frame)
 350                       ('continuation #x00)
 351                       ('text         #x01)
 352                       ('binary       #x02)
 353                       ('close        #x08)
 354                       ('ping         #x09)
 355                       ('pong         #x0A))))
 356
 357     ;; Write mask bit and length.
 358     (put-u8 port
 359             (logior (if mask #x80 #x00)
 360                     (cond
 361                      ((< length 126) length)
 362                      ((< length (expt 2 16)) 126)
 363                      (else 127))))
 364
 365     ;; Write true size when size is greater than 125.
 366     (cond
 367      ((< length 126) #f)
 368      ((< length (expt 2 16))
 369       (put-bytevector port (uint->bytevector length 2)))
 370      (else
 371       (put-bytevector port (uint->bytevector length 8))))
 372
 373     ;; Write masking key, if present.
 374     (when mask (put-bytevector port mask))
 375
 376     ;; Write data, potentially masked.
 377     (put-bytevector port (if mask (masked-data mask data) data))))