tjhintz/websockets
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Compare commits

base: tjhintz:0.0.1
Branches Tags
tjhintz:master
tjhintz:0.1.6 tjhintz:0.1.5 tjhintz:0.1.4 tjhintz:0.1.3 tjhintz:0.1.2 tjhintz:0.1.1 tjhintz:0.1.0 tjhintz:0.0.1
...
compare: tjhintz:0.1.0
Branches Tags
tjhintz:master
tjhintz:0.1.6 tjhintz:0.1.5 tjhintz:0.1.4 tjhintz:0.1.3 tjhintz:0.1.2 tjhintz:0.1.1 tjhintz:0.1.0 tjhintz:0.0.1

22 Commits
0.0.1 ... 0.1.0

Author SHA1 Message Date
Thomas Hintz
3efccc88aa Setting new version. 2014-10-18 10:08:23 -07:00
Thomas Hintz
195d55732d Removing unused utf8 C validators. 2014-10-18 10:07:53 -07:00
Thomas Hintz
91396e71e0 Adding hello example/test. 2014-10-18 09:58:16 -07:00
Thomas Hintz
29561c4b71 Setting max message and fragment size to a larger value to accommodate 
the Autobahn test suite performance tests in the echo-server.
 2014-10-18 09:57:42 -07:00
Thomas Hintz
9446f5992d Cleaning .meta file. 2014-10-18 09:55:57 -07:00
Thomas Hintz
ecafa799d3 Improving performance of first case in UTF8 validation grammar. 2014-10-18 09:55:48 -07:00
Thomas Hintz
3692bbba77 Cleaning up imports. 2014-10-18 09:55:14 -07:00
Thomas Hintz
b1ed3de161 Adding fast ASCII only UTF8 validation. 2014-10-18 09:54:59 -07:00
Thomas Hintz
b6fae3ef78 Removing unused code and irrelevant or finished TODOs. 2014-10-18 09:54:20 -07:00
Thomas Hintz
4bb341913f Checking that the websocket is still open before pinging or timeing 
out the connection.
 2014-10-17 07:19:34 -07:00
Thomas Hintz
3fd9e266a1 Remove low level API from exports. 2014-10-17 07:18:56 -07:00
Thomas Hintz
d194289740 Switch to comparse for UTF8 validation. 2014-10-17 06:52:56 -07:00
Thomas Hintz
baf570ab65 Add another utf8 decoder. 2014-10-17 06:51:13 -07:00
Thomas Hintz
daef7b3ea4 Fix echo-server test. 2014-10-08 17:22:07 -07:00
Thomas Hintz
de406f1151 Add autobahn test suite echo server. 2014-10-08 17:20:57 -07:00
Thomas Hintz
fb9d35db77 Cleanup. 2014-10-08 17:17:45 -07:00
Thomas Hintz
a6570f2659 A few general cleanups. 2014-10-08 15:59:02 -07:00
Thomas Hintz
a79b61968f Correct and improve header upgrade error handling. 2014-10-06 16:09:43 -07:00
Thomas Hintz
9312d6d5ca Limit max message size for use with the unmask/utf8 code. Change 
default max frame size to match default max message size.
 2014-10-06 07:19:41 -07:00
Thomas Hintz
c7c8de32f9 Update connection timeout close-reason to use name instead of number. 2014-10-05 12:18:26 -07:00
Thomas Hintz
b592bd1073 Add targz download link to release-info. 2014-10-05 12:10:15 -07:00
Thomas Hintz
8044107bc7 Remove miscmacros dependency as it is not used. 2014-10-05 12:09:56 -07:00
11 changed files with 243 additions and 248 deletions
Expand all files Collapse all files

25
test/echo-server.scm Normal file
View File

@@ -0,0 +1,25 @@
(import chicken scheme posix)
(use spiffy websockets)
(ping-interval 0)
(drop-incoming-pings #f)
(propagate-common-errors #f)
(max-message-size 20971520)
(max-frame-size 20971520)
(handle-not-found
(lambda (path)
(with-websocket
(lambda ()
(let loop ()
(receive (data type) (receive-message)
(unless (eq? type 'connection-close)
(send-message data type)
(loop))))))))
(debug-log (current-output-port))
(root-path ".")
(server-port 8080)
(start-server)

12
test/hello.scm Normal file
View File

@@ -0,0 +1,12 @@
(import chicken scheme)
(use spiffy websockets)
(handle-not-found
(lambda (path)
(when (string= path "/web-socket")
(with-websocket
(lambda ()
(send-message (string-append "you said: " (receive-message))))))))
(root-path ".")
(start-server port: 8080)

13
test/index.html Normal file
View File

@@ -0,0 +1,13 @@
<html>
<body>
<script type="text/javascript">
var ws = new WebSocket("ws://localhost:8080/web-socket");
ws.onmessage = function(evt) {
alert(evt.data);
};
ws.onopen = function() {
ws.send('Hello!');
}
</script>
</body>
</html>

10
test/ws-test.spec Normal file
View File

@@ -0,0 +1,10 @@
{
"servers": [
{"agent": "AutobahnServer",
"url": "ws://localhost:8080/web-socket",
"options": {"version": 13}}
],
"cases": ["1.*", "2.*", "3.*", "4.*", "5.*"],
"exclude-cases": [],
"exclude-agent-cases": {}
}

74
utf8-grammar.scm Normal file
View File

@@ -0,0 +1,74 @@
(define (ucs-range->char-set/inclusive lower upper)
(ucs-range->char-set lower (add1 upper)))
(define utf8-tail
(in (ucs-range->char-set/inclusive #x80 #xBF)))
(define utf8-1
(satisfies (lambda (c) (or (< (char->integer c) 128)
(and (> (char->integer c) 128)
(< (char->integer c) 191))))))
(define utf8-2
(sequence
(in (ucs-range->char-set/inclusive #xC2 #xDF))
utf8-tail))
(define utf8-3
(any-of
(sequence
(is #\xE0)
(in (ucs-range->char-set/inclusive #xA0 #xBF))
utf8-tail)
(sequence
(in (ucs-range->char-set/inclusive #xE1 #xEC))
(repeated utf8-tail 2))
(sequence
(is #\xED)
(in (ucs-range->char-set/inclusive #x80 #x9F))
utf8-tail)
(sequence
(in (ucs-range->char-set/inclusive #xEE #xEF))
(repeated utf8-tail 2))))
(define utf8-4
(any-of
(sequence
(is #\xF0)
(in (ucs-range->char-set/inclusive #x90 #xBF))
(repeated utf8-tail 2))
(sequence
(in (ucs-range->char-set/inclusive #xF1 #xF3))
(repeated utf8-tail 3))
(sequence
(is #\xF4)
(in (ucs-range->char-set/inclusive #x80 #x8F))
(repeated utf8-tail 2))))
(define utf8-char
(any-of
utf8-1
utf8-2
utf8-3
utf8-4))
(define utf8-string
(followed-by (zero-or-more utf8-char) end-of-input))
;; (parse utf8-string (->parser-input "Hello-µ@ßöäüàá-UTF-8!!"))
;; (parse utf8-char (->parser-input #\a))
;; (define (valid-utf8? s)
;; (let ((len (string-length s)))
;; (let loop ((i 0))
;; (if (= i len)
;; #t
;; (let ((r (parse utf8-char (->parser-input (->string (string-ref s i))))))
;; (if r
;; (loop (+ i (length r)))
;; (string-ref s i)))))))
;; (valid-utf8? "Hello-µ@ßöäüàá-UTF-8!!")
;; (valid-utf8? "Hello")
;; (parse utf8-char (->parser-input (->string #\H)))
;; #\xC0

64
utf8validator.c
View File

@@ -1,64 +0,0 @@
#include "utf8validator.h"
static const uint8_t UTF8VALIDATOR_DFA[] =
{
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 00..1f
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 20..3f
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 40..5f
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 60..7f
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, // 80..9f
7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, // a0..bf
8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, // c0..df
0xa,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x4,0x3,0x3, // e0..ef
0xb,0x6,0x6,0x6,0x5,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8, // f0..ff
0x0,0x1,0x2,0x3,0x5,0x8,0x7,0x1,0x1,0x1,0x4,0x6,0x1,0x1,0x1,0x1, // s0..s0
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,1,1,1,0,1,0,1,1,1,1,1,1, // s1..s2
1,2,1,1,1,1,1,2,1,2,1,1,1,1,1,1,1,1,1,1,1,1,1,2,1,1,1,1,1,1,1,1, // s3..s4
1,2,1,1,1,1,1,1,1,2,1,1,1,1,1,1,1,1,1,1,1,1,1,3,1,3,1,1,1,1,1,1, // s5..s6
1,3,1,1,1,1,1,3,1,3,1,1,1,1,1,1,1,3,1,1,1,1,1,1,1,1,1,1,1,1,1,1 // s7..s8
};
#define UTF8_ACCEPT 0
#define UTF8_REJECT 1
void utf8vld_reset (utf8_validator_t* validator) {
validator->state = UTF8_ACCEPT;
validator->current_index = 0;
validator->total_index = 0;
validator->is_valid = 1;
validator->ends_on_codepoint = 1;
}
void utf8vld_validate (utf8_validator_t* validator, const uint8_t* data, size_t offset, size_t length) {
int state = validator->state;
for (size_t i = offset; i < length + offset; ++i) {
state = UTF8VALIDATOR_DFA[256 + (state << 4) + UTF8VALIDATOR_DFA[data[i]]];
if (state == UTF8_REJECT)
{
validator->state = state;
validator->current_index = i - offset;
validator->total_index += i - offset;
validator->is_valid = 0;
validator->ends_on_codepoint = 0;
return;
}
}
validator->state = state;
validator->current_index = length;
validator->total_index += length;
validator->is_valid = 1;
validator->ends_on_codepoint = validator->state == UTF8_ACCEPT;
}
int utf8_valid(const uint8_t* data, size_t len) {
utf8_validator_t validator;
utf8vld_reset(&validator);
utf8vld_validate(&validator, data, 0, len);
return validator.is_valid;
}

21
utf8validator.h
View File

@@ -1,21 +0,0 @@
#ifndef UTF8_VALIDATOR_H
#define UTF8_VALIDATOR_H
#include <stdlib.h>
#include <stdint.h>
typedef struct {
size_t current_index;
size_t total_index;
int state;
int is_valid;
int ends_on_codepoint;
} utf8_validator_t;
extern void utf8vld_reset (utf8_validator_t* validator);
extern void utf8vld_validate (utf8_validator_t* validator, const uint8_t* data, size_t offset, size_t length);
extern int utf8_valid(const uint8_t* data, size_t len);
#endif // UTF8_VALIDATOR_H

8
websockets.meta
View File

@@ -4,7 +4,7 @@
(synopsis "websockets provides a websocket API.") (synopsis "websockets provides a websocket API.")
(license "BSD") (license "BSD")
(category web) (category web)
(depends srfi-1 srfi-4 spiffy intarweb uri-common base64 simple-sha1 srfi-18 (author "Thomas Hintz")
srfi-13 miscmacros mailbox) (depends spiffy intarweb uri-common base64 simple-sha1 mailbox comparse)
;(test-depends http-client test server-test regex) (files "websockets.setup" "websockets.meta" "websockets.release-info" "LICENSE"
(files "websockets.setup" "websockets.meta" "websockets.release-info" "LICENSE")) "utf8-grammar.scm"))

3
websockets.release-info
View File

@@ -1,5 +1,6 @@
;; -*- scheme -*- ;; -*- scheme -*-
(repo git "git@bitbucket.org:thomashintz/{egg-name}.git") (repo git "git@bitbucket.org:thomashintz/{egg-name}.git")
;(uri targz "https://github.com/mario-goulart/{egg-name}/tarball/{egg-release}") (uri targz "https://bitbucket.org/thomashintz/{egg-name}/get/{egg-release}.tar.gz")
(release "0.0.1") (release "0.0.1")
(release "0.1.0")

243
websockets.scm
View File

@@ -11,47 +11,47 @@
send-message receive-message send-message receive-message
; low level API ; low level API
send-frame read-frame read-frame-payload ;; send-frame read-frame read-frame-payload
receive-fragments valid-utf8? ;; receive-fragments valid-utf8?
control-frame? upgrade-to-websocket ;; control-frame? upgrade-to-websocket
current-websocket unmask close-websocket ;; current-websocket unmask close-websocket
process-fragments ;; process-fragments
; fragment ;; ; fragment
make-fragment fragment? fragment-payload fragment-length ;; make-fragment fragment? fragment-payload fragment-length
fragment-masked? fragment-masking-key fragment-last? ;; fragment-masked? fragment-masking-key fragment-last?
fragment-optype ;; fragment-optype
) )
(import chicken scheme data-structures extras ports posix foreign) (import chicken scheme data-structures extras ports posix foreign
(use srfi-1 srfi-4 spiffy intarweb uri-common base64 simple-sha1 srfi-18 srfi-13 srfi-14 srfi-18)
srfi-13 miscmacros mailbox) (use srfi-1 srfi-4 spiffy intarweb uri-common base64 simple-sha1
mailbox comparse)
; TODO make sure all C operations check args to prevent overflows
(foreign-declare "#include \"utf8validator.c\"")
(define-inline (neq? obj1 obj2) (not (eq? obj1 obj2))) (define-inline (neq? obj1 obj2) (not (eq? obj1 obj2)))
(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))
(define access-denied ; TODO test
(make-parameter (lambda () (send-status 'forbidden "<h1>Access denied</h1>"))))
(define max-frame-size (make-parameter 65536)) ; 64KiB (define max-frame-size (make-parameter 1048576)) ; 1MiB
(define max-message-size (make-parameter 1048576)) ; 1MiB (define max-message-size
(make-parameter 1048576 ; 1MiB
(lambda (v)
(if (> v 1073741823) ; max int size for unmask/utf8 check
(signal (make-property-condition 'out-of-range))
v))))
(define (make-websocket-exception . conditions) (define (make-websocket-exception . conditions)
(apply make-composite-condition (append `(,(make-property-condition 'websocket)) (apply make-composite-condition (append `(,(make-property-condition 'websocket))
conditions))) conditions)))
(define (make-invalid-header-exception type k v)
(make-composite-condition (make-websocket-exception
(make-property-condition type k v))
(make-property-condition 'invalid-header)))
(define (make-protocol-violation-exception msg) (define (make-protocol-violation-exception msg)
(make-composite-condition (make-property-condition 'websocket) (make-composite-condition (make-property-condition 'websocket)
(make-property-condition 'protocol-error 'msg msg))) (make-property-condition 'protocol-error 'msg msg)))
@@ -74,7 +74,8 @@
('connection-close 8) ('connection-close 8)
('ping 9) ('ping 9)
('pong 10) ('pong 10)
(else (error "bad optype")))) ; TODO (else (signal (make-websocket-exception
(make-property-condition 'invalid-optype))))))
(define (control-frame? optype) (define (control-frame? optype)
(or (eq? optype 'ping) (eq? optype 'pong) (eq? optype 'connection-close))) (or (eq? optype 'ping) (eq? optype 'pong) (eq? optype 'connection-close)))
@@ -102,22 +103,11 @@
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))
(define (string->bytes str)
(let* ((lst (map char->integer (string->list str)))
(bv (make-u8vector (length lst))))
(let loop ((lst lst)
(pos 0))
(if (null? lst) bv
(begin
(u8vector-set! bv pos (car lst))
(loop (cdr lst) (+ pos 1)))))))
(define (hex-string->string hexstr) (define (hex-string->string hexstr)
;; convert a string like "a745ff12" to a string ;; convert a string like "a745ff12" to a string
(let ((result (make-string (/ (string-length hexstr) 2)))) (let ((result (make-string (/ (string-length hexstr) 2))))
@@ -178,8 +168,9 @@
(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))
@@ -195,9 +186,13 @@
(define-external wslen int len) (define-external wslen int len)
; TODO handle -1
(define-external wsv scheme-pointer payload) (define-external wsv scheme-pointer payload)
((foreign-lambda* void () ((foreign-lambda* void ()
" "
if (wslen > UINT_MAX) { return -1; }
const unsigned char* maskkey2 = wsmaskkey; const unsigned char* maskkey2 = wsmaskkey;
const unsigned int kd = *(unsigned int*)maskkey2; const unsigned int kd = *(unsigned int*)maskkey2;
const unsigned char* __restrict kb = maskkey2; const unsigned char* __restrict kb = maskkey2;
@@ -220,10 +215,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)
@@ -322,67 +319,41 @@
(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-optype
'optype frame-optype))))))))))) 'optype frame-optype)))))))))))
(define (valid-utf8-2? s) (include "utf8-grammar.scm")
(define-external str c-string s)
(define-external len int (string-length s))
(zero?
((foreign-lambda* int ()
"
static const uint8_t utf8d[] = {
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 00..1f
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 20..3f
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 40..5f
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 60..7f
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, // 80..9f
7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, // a0..bf
8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, // c0..df
0xa,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x4,0x3,0x3, // e0..ef
0xb,0x6,0x6,0x6,0x5,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8, // f0..ff
0x0,0x1,0x2,0x3,0x5,0x8,0x7,0x1,0x1,0x1,0x4,0x6,0x1,0x1,0x1,0x1, // s0..s0
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,1,1,1,0,1,0,1,1,1,1,1,1, // s1..s2
1,2,1,1,1,1,1,2,1,2,1,1,1,1,1,1,1,1,1,1,1,1,1,2,1,1,1,1,1,1,1,1, // s3..s4
1,2,1,1,1,1,1,1,1,2,1,1,1,1,1,1,1,1,1,1,1,1,1,3,1,3,1,1,1,1,1,1, // s5..s6
1,3,1,1,1,1,1,3,1,3,1,1,1,1,1,1,1,3,1,1,1,1,1,1,1,1,1,1,1,1,1,1, // s7..s8
};
uint32_t si;
uint32_t *state;
si = 0;
state = &si;
uint32_t type;
for (int i = 0; i < len; i++) {
// type = utf8d[(uint8_t)str[i]];
type = utf8d[*((uint8_t*)str)];
*state = utf8d[256 + (*state) * 16 + type];
if (*state != 0) // reject
break;
}
C_return(*state);
"
))
))
(define (valid-utf8? s) (define (valid-utf8? s)
(let ((len (string-length s))) (or (let ((len (string-length s)))
((foreign-lambda int "utf8_valid" scheme-pointer int) ; Try to validate as an ascii string first. Its essentially
s len))) ; 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 ()
"
if (ws_utlen > UINT_MAX) { return -1; }
for (int i = ws_utlen; i != 0; --i)
{
if (*((unsigned char*)ws_uts++) > 127)
{
C_return(0);
}
}
C_return(1);
"))))
(parse utf8-string (->parser-input s))))
(define (close-code->integer s) (define (close-code->integer s)
(if (string-null? s) (if (string-null? s)
@@ -452,7 +423,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
@@ -497,6 +468,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)
@@ -529,7 +501,8 @@ static const uint8_t utf8d[] = {
(begin (begin
(send-frame ws 'connection-close (send-frame ws 'connection-close
(u8vector 3 (close-reason->close-code close-reason)) (u8vector 3 (close-reason->close-code close-reason))
#t))))))) #t))))
"close timeout thread")))
(thread-start! close-thread) (thread-start! close-thread)
(if (> (close-timeout) 0) (if (> (close-timeout) 0)
(unless (thread-join! close-thread (close-timeout) #f) (unless (thread-join! close-thread (close-timeout) #f)
@@ -538,8 +511,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)
@@ -547,7 +519,6 @@ static const uint8_t utf8d[] = {
(define (websocket-compute-handshake client-key) (define (websocket-compute-handshake client-key)
(let* ((key-and-magic (let* ((key-and-magic
; TODO generate new, randome, secure key every time
(string-append client-key "258EAFA5-E914-47DA-95CA-C5AB0DC85B11")) (string-append client-key "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"))
(key-and-magic-sha1 (sha1-sum key-and-magic))) (key-and-magic-sha1 (sha1-sum key-and-magic)))
(base64-encode key-and-magic-sha1))) (base64-encode key-and-magic-sha1)))
@@ -583,21 +554,22 @@ static const uint8_t utf8d[] = {
(lambda () (lambda ()
(let loop () (let loop ()
(thread-sleep! (ping-interval)) (thread-sleep! (ping-interval))
(send-message 'ping "" ws) (when (eq? (websocket-state ws) 'open)
(loop)))))) (send-message "" 'ping ws)
(loop))))
"ping thread")))
; make sure the request meets the spec for websockets ; make sure the request meets the spec for websockets
(cond ((not (and (eq? (header-value 'connection headers #f) 'upgrade) (cond ((not (and (eq? (header-value 'connection headers #f) 'upgrade)
(string-ci= (car (header-value 'upgrade headers '(""))) "websocket"))) (string-ci= (car (header-value 'upgrade headers '(""))) "websocket")))
(signal (make-invalid-header-exception 'upgrade 'value (signal (make-websocket-exception
(header-value 'upgrade headers #f)))) (make-property-condition 'missing-upgrade-header))))
((not (string= (header-value 'sec-websocket-version headers "") "13")) ((not (string= (header-value 'sec-websocket-version headers "") "13"))
(signal (make-invalid-header-exception (with-headers ; TODO test
'websocket-version 'version `((sec-websocket-version "13"))
(header-value 'sec-websocket-version headers #f)))) (lambda () (send-status 'upgrade-required))))
((not ((accept-connection) (header-value 'origin headers ""))) ((not ((accept-connection) (header-value 'origin headers "")))
(signal (make-invalid-header-exception 'origin 'value ((access-denied))))
(header-value 'origin headers #f)))))
(with-headers (with-headers
`((upgrade ("WebSocket" . #f)) `((upgrade ("WebSocket" . #f))
@@ -616,14 +588,16 @@ static const uint8_t utf8d[] = {
; Add one to attempt to alleviate checking the timestamp ; Add one to attempt to alleviate checking the timestamp
; right before when the timeout should happen. ; right before when the timeout should happen.
(thread-sleep! (+ 1 (connection-timeout))) (thread-sleep! (+ 1 (connection-timeout)))
(when (eq? (websocket-state ws) 'open)
(if (< (- (time->seconds (current-time)) (if (< (- (time->seconds (current-time))
(time->seconds (websocket-last-message-timestamp ws))) (time->seconds (websocket-last-message-timestamp ws)))
(connection-timeout)) (connection-timeout))
(loop) (loop)
(begin (thread-signal! (websocket-user-thread ws) (begin (thread-signal!
(websocket-user-thread ws)
(make-websocket-exception (make-websocket-exception
(make-property-condition 'connection-timeout))) (make-property-condition 'connection-timeout)))
(close-websocket ws close-reason: 1001)))))))) (close-websocket ws close-reason: 'going-away)))))))))
(when (> (ping-interval) 0) (when (> (ping-interval) 0)
(thread-start! ping-thread)) (thread-start! ping-thread))
@@ -631,6 +605,15 @@ static const uint8_t utf8d[] = {
ws)) ws))
(define (with-websocket proc #!optional (concurrent #f)) (define (with-websocket proc #!optional (concurrent #f))
(define (handle-error close-reason exn)
(set-websocket-state! (current-websocket) 'closing)
(close-websocket (current-websocket) close-reason: close-reason)
(unless (port-closed? (request-port (current-request)))
(close-input-port (request-port (current-request))))
(unless (port-closed? (response-port (current-response)))
(close-output-port (response-port (current-response))))
(when (propagate-common-errors)
(signal exn)))
(parameterize (parameterize
((current-websocket (websocket-accept concurrent))) ((current-websocket (websocket-accept concurrent)))
(condition-case (condition-case
@@ -638,49 +621,11 @@ static const uint8_t utf8d[] = {
(close-websocket) (close-websocket)
(close-input-port (request-port (current-request))) (close-input-port (request-port (current-request)))
(close-output-port (response-port (current-response)))) (close-output-port (response-port (current-response))))
(exn (websocket protocol-error) (exn (websocket protocol-error) (handle-error 'protocol-error exn))
(set-websocket-state! (current-websocket) 'closing) (exn (websocket invalid-data) (handle-error 'invalid-data exn))
(close-websocket (current-websocket) close-reason: 'protocol-error) (exn (websocket connection-timeout) (handle-error 'going-away exn))
(unless (port-closed? (request-port (current-request))) (exn (websocket message-too-large) (handle-error 'message-too-large exn))
(close-input-port (request-port (current-request)))) (exn () (handle-error 'unexpected-error exn)))))
(unless (port-closed? (response-port (current-response)))
(close-output-port (response-port (current-response))))
(when (propagate-common-errors)
(signal exn)))
(exn (websocket invalid-data)
(set-websocket-state! (current-websocket) 'closing)
(close-websocket (current-websocket) close-reason: 'invalid-data)
(unless (port-closed? (request-port (current-request)))
(close-input-port (request-port (current-request))))
(unless (port-closed? (response-port (current-response)))
(close-output-port (response-port (current-response))))
(when (propagate-common-errors)
(signal exn)))
(exn (websocket connection-timeout)
(set-websocket-state! (current-websocket) 'closing)
(close-websocket (current-websocket) close-reason: 'going-away)
(unless (port-closed? (request-port (current-request)))
(close-input-port (request-port (current-request))))
(unless (port-closed? (response-port (current-response)))
(close-output-port (response-port (current-response))))
(when (propagate-common-errors)
(signal exn)))
(exn (websocket message-too-large)
(set-websocket-state! (current-websocket) 'closing)
(close-websocket (current-websocket) close-reason: 'message-too-large)
(unless (port-closed? (request-port (current-request)))
(close-input-port (request-port (current-request))))
(unless (port-closed? (response-port (current-response)))
(close-output-port (response-port (current-response))))
(when (propagate-common-errors)
(signal exn)))
(exn ()
(close-websocket (current-websocket) close-reason: 1011)
(unless (port-closed? (request-port (current-request)))
(close-input-port (request-port (current-request))))
(unless (port-closed? (response-port (current-response)))
(close-output-port (response-port (current-response))))
(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)))

2
websockets.setup
View File

@@ -6,4 +6,4 @@
(install-extension 'websockets (install-extension 'websockets
'("websockets.so" "websockets.import.so") '("websockets.so" "websockets.import.so")
`((version "0.0.1"))) `((version "0.1.0")))