summaryrefslogtreecommitdiff
path: root/web/socket/frame.scm
blob: 032db77646f582d27928d05d5e546a3416268db1 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
(define-module (web socket frame)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-26)
  #:export (make-frame
            frame?
            frame-final?
            frame-type
            frame-masking-key
            frame-data

            make-pong-frame
            make-close-frame
            make-text-frame
            make-binary-frame

            continuation-frame?
            text-frame?
            binary-frame?
            close-frame?
            ping-frame?
            pong-frame?
            fragment-frame?
            first-fragment-frame?
            final-fragment-frame?
            control-frame?
            data-frame?

            frame-length
            frame-concatenate
            text-frame->string
            text-frames->string

            read-frame
            write-frame))

;;;
;;; WebSocket frames
;;;

(define-record-type <frame>
  (make-frame final? type masking-key data)
  frame?
  (final? frame-final?)
  (type frame-type)
  (masking-key frame-masking-key)
  (data frame-data))

(define (display-frame frame port)
  (format port "#<frame final?: ~a type: ~a masking-key: ~a length: ~d>"
          (frame-final? frame)
          (frame-type frame)
          (frame-masking-key frame)
          (frame-length frame)))

(set-record-type-printer! <frame> display-frame)

(define* (make-pong-frame bv #:optional (masking-key #f))
  (make-frame #t 'pong masking-key bv))

(define* (make-close-frame bv #:optional (masking-key #f))
  (make-frame #t 'close masking-key bv))

(define* (make-text-frame str #:optional (masking-key #f))
  (make-frame #t 'text masking-key (string->utf8 str)))

(define* (make-binary-frame bv #:optional (masking-key #f))
  (make-frame #t 'binary masking-key bv))

(define (continuation-frame? frame)
  "Return #t if FRAME is a continuation frame."
  (eq? (frame-type frame) 'continuation))

(define (text-frame? frame)
  "Return #t if FRAME is a text frame."
  (eq? (frame-type frame) 'text))

(define (binary-frame? frame)
  "Return #t if FRAME is a binary frame."
  (eq? (frame-type frame) 'binary))

(define (close-frame? frame)
  "Return #t if FRAME is a close frame."
  (eq? (frame-type frame) 'close))

(define (ping-frame? frame)
  "Return #t if FRAME is a ping frame."
  (eq? (frame-type frame) 'ping))

(define (pong-frame? frame)
  "Return #t if FRAME is a pong frame."
  (eq? (frame-type frame) 'pong))

;; See section 5.4 - Fragmentation
(define (fragment-frame? frame)
  "Return #t if FRAME is an incomplete message."
  (or (continuation-frame? frame)
      (not (frame-final? frame))))

(define (first-fragment-frame? frame)
  "Return #t if FRAME is the first piece of a fragmented message."
  (and (not (frame-final? frame))
       (data-frame? frame)))

(define (final-fragment-frame? frame)
  "Return #t if FRAME is the final piece of a fragmented message."
  (and (frame-final? frame)
       (continuation-frame? frame)))

;; See section 5.5 - Control Frames
(define (control-frame? frame)
  "Return #t if FRAME is a control frame."
  (or (close-frame? frame)
      (ping-frame? frame)
      (pong-frame? frame)))

;; See section 5.6 - Data Frames
(define (data-frame? frame)
  "Return #t if FRAME is a data frame."
  (or (text-frame? frame)
      (binary-frame? frame)))

(define (frame-length frame)
  "Return the length of the data bytevector in FRAME."
  (bytevector-length (frame-data frame)))

(define (text-frame->string frame)
  "Convert FRAME, an unfragmented text frame, into a string."
  (utf8->string (frame-data frame)))

(define (frame-concatenate frames)
  "Concatenate the data in FRAMES, a list of fragmented frames, into a
single bytevector."
  (let ((bv (make-bytevector (reduce + 0 (map frame-length frames)))))
    (let loop ((frames frames)
               (offset 0))
      (match frames
        (() bv)
        ((frame . rest)
         (let ((length (frame-length frame)))
           (bytevector-copy! (frame-data frame) 0 bv offset length)
           (loop rest (+ offset length))))))))

(define (text-frames->string frames)
  "Convert FRAMES, a list of fragmented text frames, into a single
concatenated string."
  (utf8->string (frame-concatenate frames)))

(define (call-with-input-bytevector bv proc)
  "Call PROC with one argument: an open input port that reads from the
bytevector BV."
  (let ((port (open-bytevector-input-port bv)))
    (dynamic-wind
      (const #t)
      (lambda ()
        (proc port))
      (lambda ()
        (close-port port)))))

(define (close-frame->status frame)
  "Convert FRAME, a close frame, into a pair.  The \"car\" of the pair
is a positive integer status code, and the \"cdr\" is a string
containing the explanation, if present."
  (define (read-status-code)
    (match (bytevector-sint-ref (frame-data frame) 0 (endianness big) 2)
      ;; See section 7.4
      ((and (or 1005 1006 1015) status)
       (websocket-error "invalid use of reserved status code: " status))
      (status status)))

  (let ((length (frame-length frame)))
    (cond
     ((zero? length) ; unspecified closing status
      '(1005 . ""))
     ((= length 2) ; status code only
      (cons (read-status-code) ""))
     (else ; status + reason
      (cons (read-status-code)
            (call-with-input-bytevector (frame-data frame)
              (lambda (port)
                ;; Throw away the status code.
                (get-u8 port)
                (get-u8 port)
                ;; Now read the reason.
                (read-string port))))))))


;;;
;;; Frame reader
;;;

;; See section 5.3 - Client-to-Server Masking
(define (mask-bytevector! bv masking-key)
  "Apply the WebSocket masking algorithm to the bytevector BV using
MASKING-KEY."
  (let loop ((i 0))
    (when (< i (bytevector-length bv))
      (let ((masked (logxor (u8vector-ref bv i)
                            (u8vector-ref masking-key (modulo i 4)))))
        (u8vector-set! bv i masked)
        (loop (1+ i))))))

(define (websocket-error message . args)
  (apply error message args))

;; See section 5.2 - Base Framing Protocol
(define (read-frame port)
  (define (opcode->frame-type opcode)
    (match opcode
      (#x0 'continuation)
      (#x1 'text)
      (#x2 'binary)
      (#x8 'close)
      (#x9 'ping)
      (#xA 'pong)
      (else (websocket-error "invalid opcode: " opcode))))

  (define (control-frame? type)
    (memq type '(close ping pong)))

  (define (parse-fin-bit octet)
    ;; Test the first bit of the octet.
    (not (zero? (logand #x80 octet))))

  (define (parse-opcode octet final?)
    ;; The opcode is stored in the least-significant nibble of the
    ;; octet.
    (let ((type (opcode->frame-type (logand #x0f octet))))
      ;; Section 5.5 specifies that control frames must not be
      ;; fragmented.
      (when (and (not final?) (control-frame? type))
        (websocket-error "fragmented control frame: " type))
      type))

  (define (parse-mask-bit octet)
    (not (zero? (logand #x80 octet))))

  (define (parse-length octet)
    ;; For lengths <= 125, the frame length is encoded in the last 7
    ;; bits of the octet.  If this number is 126, then the true length
    ;; is encoded in the following 16 bits.  If the number is 127,
    ;; then the true length is encoded in the following 64 bits.
    (match (logand #x7f octet)
      (126
       (bytevector-u16-ref (get-bytevector-n port 2) 0 (endianness big)))
      (127
       (bytevector-u64-ref (get-bytevector-n port 8) 0 (endianness big)))
      (length length)))

  (define (parse-masking-key)
    ;; Masking keys are always 32 bits.
    (get-bytevector-n port 4))

  (define (read-data type masking-key length)
    ;; Section 5.5 specifies that control frame bodies may not exceed
    ;; 125 bytes.
    (when (and (> length 125)
               (control-frame? type))
      (websocket-error "control frame to large: " type length))

    (let ((bv (get-bytevector-n port length)))
      (when masking-key
        (mask-bytevector! bv masking-key))
      bv))

  (let* ((type-byte (get-u8 port))
         (length-byte (get-u8 port))
         (final? (parse-fin-bit type-byte))
         (type (parse-opcode type-byte final?))
         (mask? (parse-mask-bit length-byte))
         (length (parse-length length-byte))
         (masking-key (and mask? (parse-masking-key)))
         (data (read-data type masking-key length)))
    (make-frame final? type masking-key data)))


;;;
;;; Frame writer
;;;

(define* (write-frame frame #:optional (port (current-output-port)))
  ;; Packs an unsigned integer into a bytevector in network byte
  ;; order.
  (define (uint->bytevector n size)
    (uint-list->bytevector (list n) (endianness big) size))

  (define (masked-data mask data)
    (let* ((length (bytevector-length data))
           (bv     (make-bytevector length)))
      (mask-bytevector! bv mask)
      bv))

  (let ((length (frame-length frame))
        (mask   (frame-masking-key frame))
        (data   (frame-data frame)))
    ;; Write FIN bit and opcode.
    (put-u8 port
            (logior (if (frame-final? frame) #x80 #x00)
                    (match (frame-type frame)
                      ('continuation #x00)
                      ('text         #x01)
                      ('binary       #x02)
                      ('close        #x08)
                      ('ping         #x09)
                      ('pong         #x0A))))

    ;; Write mask bit and length.
    (put-u8 port
            (logior (if mask #x80 #x00)
                    (cond
                     ((< length 126) length)
                     ((< length (expt 2 16)) 126)
                     (else 127))))

    ;; Write true size when size is greater than 125.
    (cond
     ((< length 126) #f)
     ((< length (expt 2 16))
      (put-bytevector port (uint->bytevector length 2)))
     (else
      (put-bytevector port (uint->bytevector length 8))))

    ;; Write masking key, if present.
    (when mask (put-bytevector port mask))

    ;; Write data, potentially masked.
    (put-bytevector port (if mask (masked-data mask data) data))))