From 7eb9d00f81c26b1fbbc8edfcb8f5e1ff33ea4b1b Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Wed, 18 Nov 2020 16:12:28 +0100 Subject: [PATCH] websocket: Queue fragmented frames to avoid interleaving. * 8sync/systems/websocket/client.scm ()[frames]: New slot. (websocket-send): Use it to queue fragmented frames. Acked-by: Jan (janneke) Nieuwenhuizen --- 8sync/systems/websocket/client.scm | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/8sync/systems/websocket/client.scm b/8sync/systems/websocket/client.scm index 4986672..93fcdeb 100644 --- a/8sync/systems/websocket/client.scm +++ b/8sync/systems/websocket/client.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2016 David Thompson ;;; Copyright © 2017 Christopher Allan Webber ;;; Copyright © 2019, 2020 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2020 Rutger van Beusekom ;;; ;;; 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 @@ -130,13 +132,18 @@ (cons frame (loop end))))))) (define-method (websocket-send (websocket ) message data) - (catch #t ; expect: wrong-type-arg (open port), system-error + (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)))))) + (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))))))) (lambda (key . args) (unless (and (memq key '(system-error wrong-type-arg)) (match args -- 2.31.1