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>
5 ;;; This file is part of guile-websocket.
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.
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.
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/>.
23 ;; WebSocket frame abstraction.
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)
74 (define-record-type <frame>
75 (make-frame final? type masking-key data)
79 (masking-key frame-masking-key)
82 (define (display-frame frame port)
83 (format port "#<frame final?: ~a type: ~a masking-key: ~a length: ~d>"
86 (frame-masking-key frame)
87 (frame-length frame)))
89 (set-record-type-printer! <frame> display-frame)
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
95 (make-frame #t 'ping masking-key bv))
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
101 (make-frame #t 'pong masking-key bv))
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
107 (make-frame #t 'close masking-key bv))
109 (define* (make-text-frame text #:optional masking-key #:key (final? #t) (continuation? #f)) ;; bah: optional
110 "Return a text data frame containing the string TEXT, masked with MASKING-KEY.
111 By default, the text is unmasked."
112 (make-frame final? (if continuation? 'continuation 'text) masking-key (string->utf8 text)))
114 (define* (make-binary-frame bv #:optional masking-key #:key (final? #t) (continuation? #f))
115 "Return a binary data frame containing the contents of the
116 bytevector BV, masked with MASKING-KEY. By default, the data is
118 (make-frame final? (if continuation? 'continuation 'binary) masking-key bv))
120 (define (continuation-frame? frame)
121 "Return #t if FRAME is a continuation frame."
122 (eq? (frame-type frame) 'continuation))
124 (define (text-frame? frame)
125 "Return #t if FRAME is a text frame."
126 (eq? (frame-type frame) 'text))
128 (define (binary-frame? frame)
129 "Return #t if FRAME is a binary frame."
130 (eq? (frame-type frame) 'binary))
132 (define (close-frame? frame)
133 "Return #t if FRAME is a close frame."
134 (eq? (frame-type frame) 'close))
136 (define (ping-frame? frame)
137 "Return #t if FRAME is a ping frame."
138 (eq? (frame-type frame) 'ping))
140 (define (pong-frame? frame)
141 "Return #t if FRAME is a pong frame."
142 (eq? (frame-type frame) 'pong))
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))))
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)))
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)))
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)
165 (pong-frame? frame)))
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)))
173 (define (frame-length frame)
174 "Return the length of the data bytevector in FRAME."
175 (bytevector-length (frame-data frame)))
177 (define (text-frame->string frame)
178 "Convert FRAME, an unfragmented text frame, into a string."
179 (utf8->string (frame-data frame)))
181 (define (frame-concatenate frames)
182 "Concatenate the data in FRAMES, a list of fragmented frames, into a
184 (let ((bv (make-bytevector (reduce + 0 (map frame-length frames)))))
185 (let loop ((frames frames)
190 (let ((length (frame-length frame)))
191 (bytevector-copy! (frame-data frame) 0 bv offset length)
192 (loop rest (+ offset length))))))))
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)))
199 (define (call-with-input-bytevector bv proc)
200 "Call PROC with one argument: an open input port that reads from the
202 (let ((port (open-bytevector-input-port bv)))
208 (close-port port)))))
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)
217 ((and (or 1005 1006 1015) status)
218 (websocket-error "invalid use of reserved status code: " status))
221 (let ((length (frame-length frame)))
223 ((zero? length) ; unspecified closing status
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)
231 ;; Throw away the status code.
234 ;; Now read the reason.
235 (read-string port))))))))
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
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)
253 (define (websocket-error message . args)
254 (apply error message args))
256 ;; See section 5.2 - Base Framing Protocol
257 (define (read-frame port)
258 (define (opcode->frame-type opcode)
266 (else (websocket-error "invalid opcode: " opcode))))
268 (define (control-frame? type)
269 (memq type '(close ping pong)))
271 (define (parse-fin-bit octet)
272 ;; Test the first bit of the octet.
273 (not (zero? (logand #x80 octet))))
275 (define (parse-opcode octet final?)
276 ;; The opcode is stored in the least significant nibble of the
278 (let ((type (opcode->frame-type (logand #x0f octet))))
279 ;; Section 5.5 specifies that control frames must not be
281 (when (and (not final?) (control-frame? type))
282 (websocket-error "fragmented control frame: " type))
285 (define (parse-mask-bit octet)
286 (not (zero? (logand #x80 octet))))
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)
295 (bytevector-u16-ref (get-bytevector-n port 2) 0 (endianness big)))
297 (bytevector-u64-ref (get-bytevector-n port 8) 0 (endianness big)))
300 (define (parse-masking-key)
301 ;; Masking keys are always 32 bits.
302 (get-bytevector-n port 4))
304 (define (read-data type masking-key length)
305 ;; Section 5.5 specifies that control frame bodies may not exceed
307 (when (and (> length 125)
308 (control-frame? type))
309 (websocket-error "control frame too large: " type length))
311 (let ((bv (get-bytevector-n port length)))
313 (unless (eof-object? bv)
314 (mask-bytevector! bv masking-key)))
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)))
332 (define* (write-frame frame #:optional (port (current-output-port)))
333 ;; Packs an unsigned integer into a bytevector in network byte
335 (define (uint->bytevector n size)
336 (uint-list->bytevector (list n) (endianness big) size))
338 (define (masked-data mask data)
339 (let ((bv (bytevector-copy data)))
340 (mask-bytevector! bv mask)
343 (let ((length (frame-length frame))
344 (mask (frame-masking-key frame))
345 (data (frame-data frame)))
346 ;; Write FIN bit and opcode.
348 (logior (if (frame-final? frame) #x80 #x00)
349 (match (frame-type frame)
357 ;; Write mask bit and length.
359 (logior (if mask #x80 #x00)
361 ((< length 126) length)
362 ((< length (expt 2 16)) 126)
365 ;; Write true size when size is greater than 125.
368 ((< length (expt 2 16))
369 (put-bytevector port (uint->bytevector length 2)))
371 (put-bytevector port (uint->bytevector length 8))))
373 ;; Write masking key, if present.
374 (when mask (put-bytevector port mask))
376 ;; Write data, potentially masked.
377 (put-bytevector port (if mask (masked-data mask data) data))))