From: Rutger van Beusekom <rutger.van.beusekom@verum.com>
Date: Wed, 18 Nov 2020 15:12:28 +0000 (+0100)
Subject: websocket: Queue fragmented frames to avoid interleaving.
X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=4eb04372da31d1b47138bf0393d8e11db9299052;hp=feb7f5104ddbcb9fd42b93d78f385804793ebb6c;p=8sync.git

websocket: Queue fragmented frames to avoid interleaving.
---

diff --git a/8sync/systems/websocket/client.scm b/8sync/systems/websocket/client.scm
index 36ee4a9..48c3c10 100644
--- a/8sync/systems/websocket/client.scm
+++ b/8sync/systems/websocket/client.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2016 David Thompson <davet@gnu.org>
 ;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
 ;;; Copyright © 2019, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2020 Rutger van Beusekom <rutger.van.beusekom@gmail.com>
 ;;;
 ;;; This file is part of guile-websocket.
 ;;;
@@ -71,6 +72,7 @@
   (url #:getter .url #:init-value #f #:init-keyword #:url)
   (uri #:accessor .uri #:init-value #f #:init-keyword #:uri)
   (entropy-port #:accessor .entropy-port #:init-form (open-entropy-port))
+  (frames #:accessor .frames #:init-value '())
 
   (on-close #:init-keyword #:on-close
                  #:init-value no-op
@@ -129,19 +131,46 @@
         (if final? (list frame)
             (cons frame (loop end)))))))
 
-(define-method (websocket-send (websocket <websocket>) message data)
+(define-method (websocket-direct-send (websocket <websocket>) message data)
   (catch #t           ; expect: wrong-type-arg (open port), system-error
     (lambda _
       (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))))))
+            (loop (cdr frames) (cons (car frames) written)))
+          ;;(format (current-error-port) "done\n")
+          )))
     (lambda (key . args)
       (let ((message (format #f "~a: ~s" key args)))
         ((.on-error websocket) websocket (format #f "send failed: ~s ~a\n" websocket message))
         (websocket-close websocket message)))))
 
+(define-method (websocket-queue-or-send (websocket <websocket>) message data)
+  (catch #t         ; expect: wrong-type-arg (open port), system-error
+    (lambda _
+      (let* ((frames (make-fragmented-frames data))
+	     (frames? (pair? (.frames websocket))))
+	(set! (.frames websocket) (append (.frames websocket) frames))
+	(unless frames?
+	  (let loop ()
+	    (let ((frames (.frames websocket)))
+	      (when (pair? frames)
+		(write-frame (car frames) (.socket websocket))
+		(set! (.frames websocket) (cdr (.frames websocket)))
+		(loop))
+              ;;(unless (pair? frames) (format (current-error-port) "done\n"))
+              )))))
+    (lambda (key . args)
+      (let ((message (format #f "~a: ~s" key args)))
+        ((.on-error websocket) websocket (format #f "send failed: ~s ~a\n" websocket message))
+        (websocket-close websocket message)))))
+
+(define-method (websocket-send (websocket <websocket>) message data)
+  (websocket-queue-or-send websocket message data)
+  ;;(websocket-direct-send websocket message data)
+  )
+
 (define-method (websocket-init (websocket <websocket>) message)
   (and=> (.url websocket) (cut websocket-open websocket message <>)))