Releasing version 0.1.6.

Fixing flush-output on send-frame.
Re-exposing current-websocket.
2015-08-04 16:21:54 -07:00 · 2015-08-04 16:20:48 -07:00 · 2015-06-28 19:33:41 -07:00 · 2015-04-18 11:44:46 -07:00 · 2015-04-18 11:41:00 -07:00 · 2015-04-18 11:36:35 -07:00
11 changed files with 265 additions and 302 deletions
--- a/test/echo-server.scm
+++ b/test/echo-server.scm
@@ -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)
+
+
--- a/test/hello.scm
+++ b/test/hello.scm
@@ -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)
--- a/test/index.html
+++ b/test/index.html
@@ -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>
--- a/test/ws-test.spec
+++ b/test/ws-test.spec
@@ -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": {}
+}
--- a/utf8-grammar.scm
+++ b/utf8-grammar.scm
@@ -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
--- a/utf8validator.c
+++ b/utf8validator.c
@@ -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;
-}
--- a/utf8validator.h
+++ b/utf8validator.h
@@ -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
--- a/websockets.meta
+++ b/websockets.meta
@@ -4,7 +4,7 @@
 (synopsis "websockets provides a websocket API.")
 (license "BSD")
 (category web)
- (depends srfi-1 srfi-4 spiffy intarweb uri-common base64 simple-sha1 srfi-18
-          srfi-13 miscmacros mailbox)
- ;(test-depends http-client test server-test regex)
- (files "websockets.setup" "websockets.meta" "websockets.release-info" "LICENSE"))
+ (author "Thomas Hintz")
+ (depends (spiffy 5.3.1) intarweb uri-common base64 simple-sha1 mailbox comparse)
+ (files "websockets.setup" "websockets.meta" "websockets.release-info" "LICENSE"
+        "utf8-grammar.scm"))
--- a/websockets.release-info
+++ b/websockets.release-info
@@ -1,5 +1,12 @@
 ;; -*- scheme -*-
 (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.1.0")
+(release "0.1.1")
+(release "0.1.2")
+(release "0.1.3")
+(release "0.1.4")
+(release "0.1.5")
+(release "0.1.6")
--- a/websockets.scm
+++ b/websockets.scm
@@ -8,50 +8,50 @@

   ; 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
-   receive-fragments valid-utf8?
-   control-frame? upgrade-to-websocket
-   current-websocket unmask close-websocket
-   process-fragments
+   ;; send-frame read-frame read-frame-payload
+   ;; receive-fragments valid-utf8?
+   ;; control-frame? upgrade-to-websocket
+   ;; current-websocket unmask close-websocket
+   ;; process-fragments

-   ; fragment
-   make-fragment fragment? fragment-payload fragment-length
-   fragment-masked? fragment-masking-key fragment-last?
-   fragment-optype
+   ;; ; fragment
+   ;; make-fragment fragment? fragment-payload fragment-length
+   ;; fragment-masked? fragment-masking-key fragment-last?
+   ;; fragment-optype
   )

-(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 miscmacros mailbox)
-
-; TODO make sure all C operations check args to prevent overflows
-(foreign-declare "#include \"utf8validator.c\"")
+(import chicken scheme data-structures extras ports posix foreign
+        srfi-13 srfi-14 srfi-18)
+(use srfi-1 srfi-4 spiffy intarweb uri-common base64 simple-sha1
+     mailbox comparse)

 (define-inline (neq? obj1 obj2) (not (eq? obj1 obj2)))

 (define current-websocket (make-parameter #f))
 (define ping-interval (make-parameter 15))
 (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 drop-incoming-pings (make-parameter #t))
 (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-message-size (make-parameter 1048576)) ; 1MiB
+(define max-frame-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)
  (apply make-composite-condition (append `(,(make-property-condition 'websocket))
                                          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)
  (make-composite-condition (make-property-condition 'websocket)
                            (make-property-condition 'protocol-error 'msg msg)))
@@ -74,7 +74,8 @@
    ('connection-close 8)
    ('ping 9)
    ('pong 10)
-    (else (error "bad optype")))) ; TODO
+    (else (signal (make-websocket-exception
+                   (make-property-condition 'invalid-optype))))))

 (define (control-frame? optype)
  (or (eq? optype 'ping) (eq? optype 'pong) (eq? optype 'connection-close)))
@@ -102,22 +103,11 @@
  fragment?
  (payload fragment-payload)
  (length fragment-length)
-  (masked fragment-masked?)
+  (masked fragment-masked? set-fragment-masked!)
  (masking-key fragment-masking-key)
  (fin fragment-last?)
  (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)
  ;; convert a string like "a745ff12" to a string
  (let ((result (make-string (/ (string-length hexstr) 2))))
@@ -176,10 +166,12 @@
     outbound-port)

    (write-string data len outbound-port)
+    (flush-output outbound-port)
    #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?
+  (optype->opcode optype) ; triggers error if invalid
  (dynamic-wind
      (lambda () (mutex-lock! (websocket-send-mutex ws)))
      (lambda () (send-frame ws optype data #t))
@@ -191,84 +183,44 @@
  (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)
-
-  (define-external wsv scheme-pointer payload)
-  ((foreign-lambda* void ()
+  ((foreign-lambda* void ((blob wsmaskkey) (size_t wslen) (scheme-pointer wsv))
 "
    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)
  (if (fragment-masked? fragment)
-      (websocket-unmask-frame-payload
+      (let ((r (websocket-unmask-frame-payload
                (fragment-payload fragment)
                (fragment-length fragment)
-       (fragment-masking-key fragment))
+                (fragment-masking-key fragment))))
+             (set-fragment-masked! fragment #f)
+             r)
      (fragment-payload fragment)))

 (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))
@@ -322,67 +274,40 @@
             (read-frame-payload inbound-port frame-payload-length)
             frame-payload-length frame-masked
             frame-masking-key frame-fin frame-optype))
-           ((eq? frame-optype 'connection-close)
+           ((eq? frame-optype 'connection-close) ; TODO, same as above?
            (make-fragment
             (read-frame-payload inbound-port frame-payload-length)
             frame-payload-length frame-masked frame-masking-key
             frame-fin frame-optype))
           (else
-            (thread-signal! (websocket-user-thread ws)
-                            (make-websocket-exception
-                             (make-property-condition 'unhandled-opcode
-                                                      'optype frame-optype)))
            (signal (make-websocket-exception
-                     (make-property-condition 'unhandled-opcode
+                     (make-property-condition 'unhandled-optype
                                              'optype frame-optype)))))))))))

-(define (valid-utf8-2? s)
-  (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);
-"
-))
-  ))
+(include "utf8-grammar.scm")

 (define (valid-utf8? s)
-  (let ((len (string-length s)))
-    ((foreign-lambda int "utf8_valid" scheme-pointer int)
-     s len)))
+  (or (let ((len (string-length s)))
+         ; 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.
+         (= 1
+            ((foreign-lambda* int ((size_t ws_utlen) (scheme-pointer ws_uts))
+"
+    if (ws_utlen > UINT_MAX) { return -1; }
+
+    int i;
+    for (i = ws_utlen; i != 0; --i)
+    {
+        if (*((unsigned char*)ws_uts++) > 127)
+        {
+            C_return(0);
+        }
+    }
+
+    C_return(1);
+") len s)))
+      (parse utf8-string (->parser-input s))))

 (define (close-code->integer s)
  (if (string-null? s)
@@ -452,7 +377,7 @@ static const uint8_t utf8d[] = {
                 ; immediate response
                 ((and (eq? optype 'ping) last-frame (<= len 125))
                  (unless (drop-incoming-pings)
-                          (send-message 'pong (unmask fragment)))
+                          (send-message (unmask fragment) 'pong))
                  (loop fragments first type total-size))

                 ; protocol violation checks
@@ -480,8 +405,13 @@ static const uint8_t utf8d[] = {
 (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,6 +427,7 @@ static const uint8_t utf8d[] = {
                   (values #!eof optype)
                   (process-fragments fragments optype)))))

+; TODO does #!optional and #!key work together?
 (define (close-websocket #!optional (ws (current-websocket))
                         #!key (close-reason 'normal) (data (make-u8vector 0)))
  (define invalid-close-reason #f)
@@ -525,11 +456,15 @@ static const uint8_t utf8d[] = {
                                        #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))
-                                        #t)))))))
+                                        #t))))
+          "close timeout thread")))
    (thread-start! close-thread)
    (if (> (close-timeout) 0)
        (unless (thread-join! close-thread (close-timeout) #f)
@@ -538,8 +473,7 @@ static const uint8_t utf8d[] = {
                ;;                 (make-websocket-exception
                ;;                  (make-property-condition 'close-timeout)))
                )
-        (thread-join! close-thread))
-    (log-to (error-log) "closed")))
+        (thread-join! close-thread))))


 (define (sha1-sum in-bv)
@@ -547,7 +481,6 @@ static const uint8_t utf8d[] = {

 (define (websocket-compute-handshake client-key)
  (let* ((key-and-magic
-          ; TODO generate new, randome, secure key every time
          (string-append client-key "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"))
         (key-and-magic-sha1 (sha1-sum key-and-magic)))
    (base64-encode key-and-magic-sha1)))
@@ -583,21 +516,22 @@ static const uint8_t utf8d[] = {
           (lambda ()
             (let loop ()
               (thread-sleep! (ping-interval))
-               (send-message 'ping "" ws)
-               (loop))))))
+               (when (eq? (websocket-state ws) 'open)
+                     (send-message "" 'ping ws)
+                     (loop))))
+           "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-invalid-header-exception 'upgrade 'value
-                                                  (header-value 'upgrade headers #f))))
+           (signal (make-websocket-exception
+                    (make-property-condition 'missing-upgrade-header))))
          ((not (string= (header-value 'sec-websocket-version headers "") "13"))
-           (signal (make-invalid-header-exception
-                    'websocket-version 'version
-                    (header-value 'sec-websocket-version headers #f))))
+           (with-headers ; TODO test
+            `((sec-websocket-version "13"))
+            (lambda () (send-status 'upgrade-required))))
          ((not ((accept-connection) (header-value 'origin headers "")))
-           (signal (make-invalid-header-exception 'origin 'value
-                                                  (header-value 'origin headers #f)))))
+           ((access-denied))))

    (with-headers
     `((upgrade ("WebSocket" . #f))
@@ -616,14 +550,16 @@ static const uint8_t utf8d[] = {
                  ; Add one to attempt to alleviate checking the timestamp
                  ; right before when the timeout should happen.
                 (thread-sleep! (+ 1 (connection-timeout)))
+                 (when (eq? (websocket-state ws) 'open)
                       (if (< (- (time->seconds (current-time))
                                 (time->seconds (websocket-last-message-timestamp ws)))
                              (connection-timeout))
                           (loop)
-                     (begin (thread-signal! (websocket-user-thread ws)
+                           (begin (thread-signal!
+                                   (websocket-user-thread ws)
                                   (make-websocket-exception
                                    (make-property-condition 'connection-timeout)))
-                            (close-websocket ws close-reason: 1001))))))))
+                                  (close-websocket ws close-reason: 'going-away)))))))))

    (when (> (ping-interval) 0)
          (thread-start! ping-thread))
@@ -631,6 +567,15 @@ static const uint8_t utf8d[] = {
    ws))

 (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
   ((current-websocket (websocket-accept concurrent)))
   (condition-case
@@ -638,49 +583,11 @@ static const uint8_t utf8d[] = {
           (close-websocket)
           (close-input-port (request-port (current-request)))
           (close-output-port (response-port (current-response))))
-    (exn (websocket protocol-error)
-         (set-websocket-state! (current-websocket) 'closing)
-         (close-websocket (current-websocket) close-reason: 'protocol-error)
-         (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 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)))))))
+    (exn (websocket protocol-error) (handle-error 'protocol-error exn))
+    (exn (websocket invalid-data) (handle-error 'invalid-data exn))
+    (exn (websocket connection-timeout) (handle-error 'going-away exn))
+    (exn (websocket message-too-large) (handle-error 'message-too-large exn))
+    (exn () (handle-error 'unexpected-error exn)))))

 (define (with-concurrent-websocket proc)
  (let ((parent-thread (current-thread)))
--- a/websockets.setup
+++ b/websockets.setup
@@ -6,4 +6,4 @@

 (install-extension 'websockets
                   '("websockets.so" "websockets.import.so")
-                   `((version "0.0.1")))
+                   `((version "0.1.6")))
Author	SHA1	Message	Date
Thomas Hintz	6f56b55708	Releasing version 0.1.6.	2015-08-04 16:21:54 -07:00
Thomas Hintz	35aa88199d	Fixing flush-output on send-frame.	2015-08-04 16:20:48 -07:00
Thomas Hintz	949af5c092	Re-exposing current-websocket. Tag release 0.1.5.	2015-06-28 19:33:41 -07:00
Thomas Hintz	44caad5ae9	Releasing version 0.1.4.	2015-04-18 11:44:46 -07:00
Thomas Hintz	fa6ec7695a	Passing in values to foreign-lambda* for UTF-8 validation instead of using global variables.	2015-04-18 11:41:00 -07:00
Thomas Hintz	081209bd2f	Using size_t instead of int.	2015-04-18 11:36:35 -07:00
Thomas Hintz	90b97f7d34	Fixing unmask to pass values into foreign-lambda* instead of using global variables.	2015-04-18 11:21:18 -07:00
Thomas Hintz	fde9c289cc	Removing unused code.	2015-04-18 10:58:23 -07:00
Thomas Hintz	7f0b9d2873	Removing bogus length check.	2015-04-18 10:57:27 -07:00
Thomas Hintz	5816661ebf	Flushing output after frame is sent.	2015-04-18 10:57:12 -07:00
Thomas Hintz	946552f79c	Fixing upgrade header check.	2015-04-18 10:44:44 -07:00
Thomas Hintz	e812e3cbbe	Removing reliance on C99 standard.	2014-10-22 09:05:37 -07:00
Thomas Hintz	23cecce39d	Requiring at least spiffy 5.3.1.	2014-10-22 06:51:47 -07:00
Thomas Hintz	d8ee592823	Release version 0.1.1.	2014-10-18 11:00:32 -07:00
Thomas Hintz	221d2d0e6e	Failing connection on invalid UTF8 in close reason.	2014-10-18 10:59:34 -07:00
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