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