Releasing version 0.1.6.

Tag release 0.1.5.

websockets.meta

@@ -5,6 +5,6 @@
  (license "BSD")
  (category web)
  (author "Thomas Hintz")
- (depends spiffy intarweb uri-common base64 simple-sha1 mailbox comparse)
+ (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"))

websockets.release-info

@@ -4,3 +4,9 @@
 
 (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")

websockets.scm

@@ -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)
+  ((foreign-lambda* void ((blob wsmaskkey) (size_t wslen) (scheme-pointer wsv))
-
-  ; TODO handle -1
-
-  (define-external wsv scheme-pointer payload)
-  ((foreign-lambda* void ()
 "
-    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;
+    const size_t rem = wslen & 3;
-    for (int i = 0; i < rem; ++i)
+    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)
+    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))
-  )
 
 (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)
+    (when (and (or (eq? optype 'text) (eq? optype 'connection-close))
-               (not (valid-utf8? message-body)))
+               (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))))

websockets.setup

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