|
|
|
|
@@ -8,7 +8,7 @@
|
|
|
|
|
|
|
|
|
|
; high level API
|
|
|
|
|
with-websocket with-concurrent-websocket
|
|
|
|
|
send-message receive-message
|
|
|
|
|
send-message receive-message current-websocket
|
|
|
|
|
|
|
|
|
|
; low level API
|
|
|
|
|
;; send-frame read-frame read-frame-payload
|
|
|
|
|
@@ -166,6 +166,7 @@
|
|
|
|
|
outbound-port)
|
|
|
|
|
|
|
|
|
|
(write-string data len outbound-port)
|
|
|
|
|
(flush-output outbound-port)
|
|
|
|
|
#t))
|
|
|
|
|
|
|
|
|
|
(define (send-message data #!optional (optype 'text) (ws (current-websocket)))
|
|
|
|
|
@@ -182,35 +183,28 @@
|
|
|
|
|
(u8vector-set! tmaskkey 1 (vector-ref frame-masking-key 1))
|
|
|
|
|
(u8vector-set! tmaskkey 2 (vector-ref frame-masking-key 2))
|
|
|
|
|
(u8vector-set! tmaskkey 3 (vector-ref frame-masking-key 3))
|
|
|
|
|
(define-external wsmaskkey blob (u8vector->blob/shared tmaskkey))
|
|
|
|
|
|
|
|
|
|
(define-external wslen int len)
|
|
|
|
|
|
|
|
|
|
; TODO handle -1
|
|
|
|
|
|
|
|
|
|
(define-external wsv scheme-pointer payload)
|
|
|
|
|
((foreign-lambda* void ()
|
|
|
|
|
((foreign-lambda* void ((blob wsmaskkey) (size_t wslen) (scheme-pointer wsv))
|
|
|
|
|
"
|
|
|
|
|
if (wslen > UINT_MAX) { return -1; }
|
|
|
|
|
|
|
|
|
|
const unsigned char* maskkey2 = wsmaskkey;
|
|
|
|
|
const unsigned int kd = *(unsigned int*)maskkey2;
|
|
|
|
|
const unsigned char* __restrict kb = maskkey2;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
for (int i = wslen >> 2; i != 0; --i)
|
|
|
|
|
size_t i;
|
|
|
|
|
for (i = wslen >> 2; i != 0; --i)
|
|
|
|
|
{
|
|
|
|
|
*((unsigned int*)wsv) ^= kd;
|
|
|
|
|
wsv += 4;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
const int rem = wslen & 3;
|
|
|
|
|
for (int i = 0; i < rem; ++i)
|
|
|
|
|
const size_t rem = wslen & 3;
|
|
|
|
|
for (i = 0; i < rem; ++i)
|
|
|
|
|
{
|
|
|
|
|
*((unsigned int*)wsv++) ^= kb[i];
|
|
|
|
|
}
|
|
|
|
|
"
|
|
|
|
|
))
|
|
|
|
|
) (u8vector->blob/shared tmaskkey) len payload)
|
|
|
|
|
payload)
|
|
|
|
|
|
|
|
|
|
(define (unmask fragment)
|
|
|
|
|
@@ -226,46 +220,7 @@
|
|
|
|
|
(define (read-frame-payload inbound-port frame-payload-length)
|
|
|
|
|
(let ((masked-data (make-string frame-payload-length)))
|
|
|
|
|
(read-string! frame-payload-length masked-data inbound-port)
|
|
|
|
|
masked-data)
|
|
|
|
|
;; (let* ((masked-data (make-string frame-payload-length)))
|
|
|
|
|
;; (read-string! frame-payload-length masked-data inbound-port)
|
|
|
|
|
|
|
|
|
|
;; (define tmaskkey (make-u8vector 4 #f #t #t))
|
|
|
|
|
;; (u8vector-set! tmaskkey 0 (vector-ref frame-masking-key 0))
|
|
|
|
|
;; (u8vector-set! tmaskkey 1 (vector-ref frame-masking-key 1))
|
|
|
|
|
;; (u8vector-set! tmaskkey 2 (vector-ref frame-masking-key 2))
|
|
|
|
|
;; (u8vector-set! tmaskkey 3 (vector-ref frame-masking-key 3))
|
|
|
|
|
;; (define-external wsmaskkey blob (u8vector->blob/shared tmaskkey))
|
|
|
|
|
|
|
|
|
|
;; (define-external wslen int frame-payload-length)
|
|
|
|
|
|
|
|
|
|
;; (define-external wsv scheme-pointer masked-data)
|
|
|
|
|
|
|
|
|
|
;; (if frame-masked
|
|
|
|
|
;; (begin
|
|
|
|
|
;; ((foreign-lambda* void ()
|
|
|
|
|
;; "
|
|
|
|
|
;; const unsigned char* maskkey2 = wsmaskkey;
|
|
|
|
|
;; const unsigned int kd = *(unsigned int*)maskkey2;
|
|
|
|
|
;; const unsigned char* __restrict kb = maskkey2;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; for (int i = wslen >> 2; i != 0; --i)
|
|
|
|
|
;; {
|
|
|
|
|
;; *((unsigned int*)wsv) ^= kd;
|
|
|
|
|
;; wsv += 4;
|
|
|
|
|
;; }
|
|
|
|
|
|
|
|
|
|
;; const int rem = wslen & 3;
|
|
|
|
|
;; for (int i = 0; i < rem; ++i)
|
|
|
|
|
;; {
|
|
|
|
|
;; *((unsigned int*)wsv++) ^= kb[i];
|
|
|
|
|
;; }
|
|
|
|
|
;; "
|
|
|
|
|
;; ))
|
|
|
|
|
;; masked-data)
|
|
|
|
|
;; masked-data))
|
|
|
|
|
)
|
|
|
|
|
masked-data))
|
|
|
|
|
|
|
|
|
|
(define (read-frame total-size ws)
|
|
|
|
|
(let* ((inbound-port (websocket-inbound-port ws))
|
|
|
|
|
@@ -336,14 +291,13 @@
|
|
|
|
|
; Try to validate as an ascii string first. Its essentially
|
|
|
|
|
; free, doesn't generate garbage and is many, many times
|
|
|
|
|
; faster than the general purpose validator.
|
|
|
|
|
(define-external ws_utlen int len)
|
|
|
|
|
(define-external ws_uts scheme-pointer s)
|
|
|
|
|
(= 1
|
|
|
|
|
((foreign-lambda* int ()
|
|
|
|
|
((foreign-lambda* int ((size_t ws_utlen) (scheme-pointer ws_uts))
|
|
|
|
|
"
|
|
|
|
|
if (ws_utlen > UINT_MAX) { return -1; }
|
|
|
|
|
|
|
|
|
|
for (int i = ws_utlen; i != 0; --i)
|
|
|
|
|
int i;
|
|
|
|
|
for (i = ws_utlen; i != 0; --i)
|
|
|
|
|
{
|
|
|
|
|
if (*((unsigned char*)ws_uts++) > 127)
|
|
|
|
|
{
|
|
|
|
|
@@ -352,7 +306,7 @@
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
C_return(1);
|
|
|
|
|
"))))
|
|
|
|
|
") len s)))
|
|
|
|
|
(parse utf8-string (->parser-input s))))
|
|
|
|
|
|
|
|
|
|
(define (close-code->integer s)
|
|
|
|
|
@@ -451,8 +405,13 @@
|
|
|
|
|
(define (process-fragments fragments optype #!optional (ws (current-websocket)))
|
|
|
|
|
(let ((message-body (string-concatenate/shared
|
|
|
|
|
(reverse (map unmask fragments)))))
|
|
|
|
|
(when (and (eq? optype 'text)
|
|
|
|
|
(not (valid-utf8? message-body)))
|
|
|
|
|
(when (and (or (eq? optype 'text) (eq? optype 'connection-close))
|
|
|
|
|
(not (valid-utf8?
|
|
|
|
|
(if (eq? optype 'text)
|
|
|
|
|
message-body
|
|
|
|
|
(if (> (string-length message-body) 2)
|
|
|
|
|
(substring message-body 2)
|
|
|
|
|
"")))))
|
|
|
|
|
(set-websocket-state! ws 'error)
|
|
|
|
|
(signal (make-websocket-exception
|
|
|
|
|
(make-property-condition
|
|
|
|
|
@@ -497,7 +456,10 @@
|
|
|
|
|
#t)
|
|
|
|
|
(let loop ()
|
|
|
|
|
(receive (data type) (receive-message ws)
|
|
|
|
|
(unless (eq? type 'connection-close) (loop)))))
|
|
|
|
|
(if (eq? type 'connection-close)
|
|
|
|
|
(unless (valid-utf8? data)
|
|
|
|
|
(set! close-reason 'invalid-data))
|
|
|
|
|
(loop)))))
|
|
|
|
|
(begin
|
|
|
|
|
(send-frame ws 'connection-close
|
|
|
|
|
(u8vector 3 (close-reason->close-code close-reason))
|
|
|
|
|
@@ -560,7 +522,7 @@
|
|
|
|
|
"ping thread")))
|
|
|
|
|
|
|
|
|
|
; make sure the request meets the spec for websockets
|
|
|
|
|
(cond ((not (and (eq? (header-value 'connection headers #f) 'upgrade)
|
|
|
|
|
(cond ((not (and (member 'upgrade (header-values 'connection headers))
|
|
|
|
|
(string-ci= (car (header-value 'upgrade headers '(""))) "websocket")))
|
|
|
|
|
(signal (make-websocket-exception
|
|
|
|
|
(make-property-condition 'missing-upgrade-header))))
|
|
|
|
|
|
