|
|
@ -23,10 +23,17 @@
|
|
|
|
;; fragment-optype
|
|
|
|
;; fragment-optype
|
|
|
|
)
|
|
|
|
)
|
|
|
|
|
|
|
|
|
|
|
|
(import chicken scheme data-structures extras ports posix foreign
|
|
|
|
(cond-expand
|
|
|
|
|
|
|
|
(chicken-4
|
|
|
|
|
|
|
|
(import chicken scheme data-structures extras ports posix foreign
|
|
|
|
srfi-13 srfi-14 srfi-18)
|
|
|
|
srfi-13 srfi-14 srfi-18)
|
|
|
|
(use srfi-1 srfi-4 spiffy intarweb uri-common base64 simple-sha1
|
|
|
|
(use srfi-1 srfi-4 spiffy intarweb uri-common base64 simple-sha1
|
|
|
|
mailbox comparse)
|
|
|
|
mailbox comparse))
|
|
|
|
|
|
|
|
(chicken-5
|
|
|
|
|
|
|
|
(import scheme srfi-4 srfi-8 srfi-13 srfi-14 srfi-18 base64 comparse
|
|
|
|
|
|
|
|
intarweb mailbox simple-sha1 spiffy (chicken base) (chicken blob)
|
|
|
|
|
|
|
|
(chicken bitwise) (chicken condition) (chicken foreign)
|
|
|
|
|
|
|
|
(chicken io))))
|
|
|
|
|
|
|
|
|
|
|
|
(define-inline (neq? obj1 obj2) (not (eq? obj1 obj2)))
|
|
|
|
(define-inline (neq? obj1 obj2) (not (eq? obj1 obj2)))
|
|
|
|
|
|
|
|
|
|
|
@ -248,12 +255,12 @@
|
|
|
|
(bl1 (read-byte inbound-port)))
|
|
|
|
(bl1 (read-byte inbound-port)))
|
|
|
|
(set! frame-payload-length (+ (arithmetic-shift bl0 8) bl1))))
|
|
|
|
(set! frame-payload-length (+ (arithmetic-shift bl0 8) bl1))))
|
|
|
|
((= frame-payload-length 127)
|
|
|
|
((= frame-payload-length 127)
|
|
|
|
(define (shift i r)
|
|
|
|
(letrec ((shift (lambda (i r)
|
|
|
|
(if (< i 0)
|
|
|
|
(if (< i 0)
|
|
|
|
r
|
|
|
|
r
|
|
|
|
(shift (- i 1) (+ (arithmetic-shift (read-byte inbound-port) (* 8 i))
|
|
|
|
(shift (- i 1) (+ (arithmetic-shift (read-byte inbound-port) (* 8 i))
|
|
|
|
r))))
|
|
|
|
r))))))
|
|
|
|
(set! frame-payload-length (shift 7 0))))
|
|
|
|
(set! frame-payload-length (shift 7 0)))))
|
|
|
|
(when (or (> frame-payload-length (max-frame-size))
|
|
|
|
(when (or (> frame-payload-length (max-frame-size))
|
|
|
|
(> (+ frame-payload-length total-size) (max-message-size)))
|
|
|
|
(> (+ frame-payload-length total-size) (max-message-size)))
|
|
|
|
(signal (make-websocket-exception
|
|
|
|
(signal (make-websocket-exception
|
|
|
|