From: Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
Date: Mon, 22 Apr 2019 17:30:22 +0000 (+0200)
Subject: websocket: Support for sending fragmented frames.
X-Git-Url: https://jxself.org/git/?p=8sync.git;a=commitdiff_plain;h=715d98b09ba5745db5efc19e6d3de38e8eb38793

websocket: Support for sending fragmented frames.

* 8sync/systems/websocket/frame.scm (make-text-frame): Add keyword
parameters final and continuation.
(make-binary-frame): Likewise.
* 8sync/systems/websocket/client.scm (make-fragmented-frames): New
function.
(websocket-send): Use it to send fragmented frames.
---

diff --git a/8sync/systems/websocket/client.scm b/8sync/systems/websocket/client.scm
index 186b1b2..9f2b0f0 100644
--- 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
diff --git a/8sync/systems/websocket/frame.scm b/8sync/systems/websocket/frame.scm
index 831456a..35dc551 100644
--- a/8sync/systems/websocket/frame.scm
+++ b/8sync/systems/websocket/frame.scm
@@ -106,16 +106,16 @@ bytevector BV, masked with MASKING-KEY.  By default, the data is
 unmasked."
   (make-frame #t 'close masking-key bv))
 
-(define* (make-text-frame text #:optional masking-key)
+(define* (make-text-frame text #:optional masking-key #:key (final? #t) (continuation? #f)) ;; bah: optional
   "Return a text data frame containing the string TEXT, masked with MASKING-KEY.
 By default, the text is unmasked."
-  (make-frame #t 'text masking-key (string->utf8 text)))
+  (make-frame final? (if continuation? 'continuation 'text) masking-key (string->utf8 text)))
 
-(define* (make-binary-frame bv #:optional masking-key)
+(define* (make-binary-frame bv #:optional masking-key #:key (final? #t) (continuation? #f))
   "Return a binary data frame containing the contents of the
 bytevector BV, masked with MASKING-KEY.  By default, the data is
 unmasked."
-  (make-frame #t 'binary masking-key bv))
+  (make-frame final? (if continuation? 'continuation 'binary) masking-key bv))
 
 (define (continuation-frame? frame)
   "Return #t if FRAME is a continuation frame."