websocket: Support for sending fragmented frames.

[8sync.git] / 8sync / systems / websocket / client.scm

diff --git a/8sync/systems/websocket/client.scm b/8sync/systems/websocket/client.scm
index 186b1b29033454fef0e5b1d056f15188692ec926..9f2b0f06807a1494e51e31c5c27113543885a6a6 100644 (file)
--- a/8sync/systems/websocket/client.scm
+++ b/8sync/systems/websocket/client.scm
@@ -109,15 +109,34 @@
             ((.on-error websocket) websocket (format #f "not a websocket uri: ~s" uri-or-string))))
       ((.on-error websocket) websocket (format #f "cannot open websocket in state: ~s" (.state websocket)))))
 
+(define (subbytevector bv start end)
+  (if (= (bytevector-length bv) end) bv
+      (let* ((length (- end start))
+             (sub (make-bytevector length)))
+        (bytevector-copy! bv start sub 0 length)
+        sub)))
+
+(define* (make-fragmented-frames data #:key (fragment-size (expt 2 15)))
+  (let ((length (if (string? data) (string-length data)
+                    (bytevector-length data))))
+    (let loop ((offset 0))
+      (let* ((size (min fragment-size (- length offset)))
+             (end (+ offset size))
+             (final? (= end length))
+             (continuation? (not (zero? offset)))
+             (frame (if (string? data) (make-text-frame (substring data offset end) #:final? final? #:continuation? continuation?)
+                        (make-binary-frame (subbytevector data offset end) #:final? final? #:continuation? continuation?))))
+        (if final? (list frame)
+            (cons frame (loop end)))))))
+
 (define-method (websocket-send (websocket <websocket>) message data)
   (catch #t           ; expect: wrong-type-arg (open port), system-error
     (lambda _
-      (write-frame
-       (cond ((string? data)
-              (make-text-frame data))
-             ((bytevector? data)
-              (make-binary-frame data)))
-       (.socket websocket)))
+      (let* ((frames (make-fragmented-frames data)))
+        (let loop ((frames frames) (written '(nothing)))
+          (when (pair? frames)
+            (write-frame (car frames) (.socket websocket))
+            (loop (cdr frames) (cons (car frames) written))))))
     (lambda (key . args)
       (unless (and (memq key '(system-error wrong-type-arg))
                    (match args