A few general cleanups.

This commit is contained in:
Thomas Hintz 2014-10-08 15:59:02 -07:00
parent a79b61968f
commit a6570f2659
1 changed files with 19 additions and 18 deletions

View File

@ -34,7 +34,7 @@
(define current-websocket (make-parameter #f)) (define current-websocket (make-parameter #f))
(define ping-interval (make-parameter 15)) (define ping-interval (make-parameter 15))
(define close-timeout (make-parameter 5)) (define close-timeout (make-parameter 5))
(define connection-timeout (make-parameter 58)) (define connection-timeout (make-parameter 58)) ; a little grace period from 60s
(define accept-connection (make-parameter (lambda (origin) #t))) (define accept-connection (make-parameter (lambda (origin) #t)))
(define drop-incoming-pings (make-parameter #t)) (define drop-incoming-pings (make-parameter #t))
(define propagate-common-errors (make-parameter #f)) (define propagate-common-errors (make-parameter #f))
@ -104,7 +104,7 @@
fragment? fragment?
(payload fragment-payload) (payload fragment-payload)
(length fragment-length) (length fragment-length)
(masked fragment-masked?) (masked fragment-masked? set-fragment-masked!)
(masking-key fragment-masking-key) (masking-key fragment-masking-key)
(fin fragment-last?) (fin fragment-last?)
(optype fragment-optype)) (optype fragment-optype))
@ -180,12 +180,13 @@
(write-string data len outbound-port) (write-string data len outbound-port)
#t)) #t))
(define (send-message optype #!optional (data "") (ws (current-websocket))) (define (send-message data #!optional (optype 'text) (ws (current-websocket)))
;; TODO break up large data into multiple frames? ;; TODO break up large data into multiple frames?
(optype->opcode optype) ; triggers error if invalid
(dynamic-wind (dynamic-wind
(lambda () (mutex-lock! (websocket-send-mutex ws))) (lambda () (mutex-lock! (websocket-send-mutex ws)))
(lambda () (send-frame ws optype data #t)) (lambda () (send-frame ws optype data #t))
(lambda () (mutex-unlock! (websocket-send-mutex ws))))) (lambda () (mutex-unlock! (websocket-send-mutex ws))))
(define (websocket-unmask-frame-payload payload len frame-masking-key) (define (websocket-unmask-frame-payload payload len frame-masking-key)
(define tmaskkey (make-u8vector 4 #f #t #t)) (define tmaskkey (make-u8vector 4 #f #t #t))
@ -224,10 +225,12 @@
(define (unmask fragment) (define (unmask fragment)
(if (fragment-masked? fragment) (if (fragment-masked? fragment)
(websocket-unmask-frame-payload (let ((r (websocket-unmask-frame-payload
(fragment-payload fragment) (fragment-payload fragment)
(fragment-length fragment) (fragment-length fragment)
(fragment-masking-key fragment)) (fragment-masking-key fragment))))
(set-fragment-masked! fragment #f)
r)
(fragment-payload fragment))) (fragment-payload fragment)))
(define (read-frame-payload inbound-port frame-payload-length) (define (read-frame-payload inbound-port frame-payload-length)
@ -326,16 +329,12 @@
(read-frame-payload inbound-port frame-payload-length) (read-frame-payload inbound-port frame-payload-length)
frame-payload-length frame-masked frame-payload-length frame-masked
frame-masking-key frame-fin frame-optype)) frame-masking-key frame-fin frame-optype))
((eq? frame-optype 'connection-close) ((eq? frame-optype 'connection-close) ; TODO, same as above?
(make-fragment (make-fragment
(read-frame-payload inbound-port frame-payload-length) (read-frame-payload inbound-port frame-payload-length)
frame-payload-length frame-masked frame-masking-key frame-payload-length frame-masked frame-masking-key
frame-fin frame-optype)) frame-fin frame-optype))
(else (else
(thread-signal! (websocket-user-thread ws)
(make-websocket-exception
(make-property-condition 'unhandled-opcode
'optype frame-optype)))
(signal (make-websocket-exception (signal (make-websocket-exception
(make-property-condition 'unhandled-opcode (make-property-condition 'unhandled-opcode
'optype frame-optype))))))))))) 'optype frame-optype)))))))))))
@ -456,7 +455,7 @@ static const uint8_t utf8d[] = {
; immediate response ; immediate response
((and (eq? optype 'ping) last-frame (<= len 125)) ((and (eq? optype 'ping) last-frame (<= len 125))
(unless (drop-incoming-pings) (unless (drop-incoming-pings)
(send-message 'pong (unmask fragment))) (send-message (unmask fragment) 'pong))
(loop fragments first type total-size)) (loop fragments first type total-size))
; protocol violation checks ; protocol violation checks
@ -501,6 +500,7 @@ static const uint8_t utf8d[] = {
(values #!eof optype) (values #!eof optype)
(process-fragments fragments optype))))) (process-fragments fragments optype)))))
; TODO does #!optional and #!key work together?
(define (close-websocket #!optional (ws (current-websocket)) (define (close-websocket #!optional (ws (current-websocket))
#!key (close-reason 'normal) (data (make-u8vector 0))) #!key (close-reason 'normal) (data (make-u8vector 0)))
(define invalid-close-reason #f) (define invalid-close-reason #f)
@ -542,8 +542,7 @@ static const uint8_t utf8d[] = {
;; (make-websocket-exception ;; (make-websocket-exception
;; (make-property-condition 'close-timeout))) ;; (make-property-condition 'close-timeout)))
) )
(thread-join! close-thread)) (thread-join! close-thread))))
(log-to (error-log) "closed")))
(define (sha1-sum in-bv) (define (sha1-sum in-bv)
@ -586,7 +585,7 @@ static const uint8_t utf8d[] = {
(lambda () (lambda ()
(let loop () (let loop ()
(thread-sleep! (ping-interval)) (thread-sleep! (ping-interval))
(send-message 'ping "" ws) (send-message "" 'ping ws)
(loop)))))) (loop))))))
; make sure the request meets the spec for websockets ; make sure the request meets the spec for websockets
@ -682,7 +681,9 @@ static const uint8_t utf8d[] = {
(close-input-port (request-port (current-request)))) (close-input-port (request-port (current-request))))
(unless (port-closed? (response-port (current-response))) (unless (port-closed? (response-port (current-response)))
(close-output-port (response-port (current-response)))) (close-output-port (response-port (current-response))))
(signal (make-websocket-exception (make-property-condition 'unexpected-error))))))) (abort exn)
;(signal (make-websocket-exception (make-property-condition 'unexpected-error)))
))))
(define (with-concurrent-websocket proc) (define (with-concurrent-websocket proc)
(let ((parent-thread (current-thread))) (let ((parent-thread (current-thread)))