X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=8sync%2Fsystems%2Fwebsocket%2Fclient.scm;h=93fcdeb6ecd994143a557e6a3c5b83528f8f392a;hb=5df9f19127858a1b32df6ef543b4b10e49f1aa57;hp=9f2b0f06807a1494e51e31c5c27113543885a6a6;hpb=715d98b09ba5745db5efc19e6d3de38e8eb38793;p=8sync.git

diff --git a/8sync/systems/websocket/client.scm b/8sync/systems/websocket/client.scm
index 9f2b0f0..93fcdeb 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
@@ -130,13 +132,18 @@
             (cons frame (loop end)))))))
 
 (define-method (websocket-send (websocket <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
@@ -150,6 +157,10 @@
 (define-method (websocket-init (websocket <websocket>) message)
   (and=> (.url websocket) (cut websocket-open websocket message <>)))
 
+(define-method (websocket-socket-open? (websocket <websocket>))
+  "Return #t if .SOCKET of WEBSOCKET is open."
+  (not (port-closed? (.socket websocket))))
+
 (define-method (websocket-loop (websocket <websocket>) message)
 
   (define (handle-data-frame type data)
@@ -170,42 +181,56 @@
 
   (let loop ((fragments '())
              (type #f))
-    (let* ((socket (.socket websocket))
-           (frame (and (websocket-open? websocket)
-                       (read-frame-maybe))))
-      (cond
-       ;; EOF - port is closed.
-       ;; @@: Sometimes the eof object appears here as opposed to
-       ;;   at lookahead, but I'm not sure why
-       ((or (not frame) (eof-object? frame))
-        (close-down))
-       ;; Per section 5.4, control frames may appear interspersed
-       ;; along with a fragmented message.
-       ((close-frame? frame)
-        ;; Per section 5.5.1, echo the close frame back to the
-        ;; socket before closing the socket.  The socket may no
-        ;; longer be listening.
-        (false-if-exception
-         (write-frame (make-close-frame (frame-data frame)) socket))
-        (close-down))
-       ((ping-frame? frame)
-        ;; Per section 5.5.3, a pong frame must include the exact
-        ;; same data as the ping frame.
-        (write-frame (make-pong-frame (frame-data frame)) socket)
-        (loop fragments type))
-       ((pong-frame? frame)           ; silently ignore pongs
-        (loop fragments type))
-       ((first-fragment-frame? frame) ; begin accumulating fragments
-        (loop (list frame) (frame-type frame)))
-       ((final-fragment-frame? frame) ; concatenate all fragments
-        (handle-data-frame type (frame-concatenate
-                                 (reverse (cons frame fragments))))
-        (loop '() #f))
-       ((fragment-frame? frame)       ; add a fragment
-        (loop (cons frame fragments) type))
-       ((data-frame? frame)           ; unfragmented data frame
-        (handle-data-frame (frame-type frame) (frame-data frame))
-        (loop '() #f))))))
+    (catch #t          ;expect: wrong-type-arg (open port), system-error
+      (lambda _
+        (let* ((socket (.socket websocket))
+               (frame (and (websocket-open? websocket)
+                           (read-frame-maybe))))
+          (cond
+           ;; EOF - port is closed.
+           ;; @@: Sometimes the eof object appears here as opposed to
+           ;;   at lookahead, but I'm not sure why
+           ((or (not frame) (eof-object? frame))
+            (close-down))
+           ;; Per section 5.4, control frames may appear interspersed
+           ;; along with a fragmented message.
+           ((close-frame? frame)
+            ;; Per section 5.5.1, echo the close frame back to the
+            ;; socket before closing the socket.  The socket may no
+            ;; longer be listening.
+            (false-if-exception
+             (write-frame (make-close-frame (frame-data frame)) socket))
+            (close-down))
+           ((ping-frame? frame)
+            ;; Per section 5.5.3, a pong frame must include the exact
+            ;; same data as the ping frame.
+            (write-frame (make-pong-frame (frame-data frame)) socket)
+            (loop fragments type))
+           ((pong-frame? frame)         ; silently ignore pongs
+            (loop fragments type))
+           ((first-fragment-frame? frame) ; begin accumulating fragments
+            (loop (list frame) (frame-type frame)))
+           ((final-fragment-frame? frame) ; concatenate all fragments
+            (handle-data-frame type (frame-concatenate
+                                     (reverse (cons frame fragments))))
+            (loop '() #f))
+           ((fragment-frame? frame)     ; add a fragment
+            (loop (cons frame fragments) type))
+           ((data-frame? frame)         ; unfragmented data frame
+            (handle-data-frame (frame-type frame) (frame-data frame))
+            (loop '() #f)))))
+      (lambda (key . args)
+        (unless (and
+                 (memq key '(system-error wrong-type-arg))
+                 (match args
+                   (((or "get-u8" "get-bytevector-n" "lookahead-u8") arg ...)
+                    #t)
+                   (_ #f)))
+          (apply throw key args))
+        (let ((message (format #f "~a: ~s" key args)))
+          ((.on-error websocket) websocket (format #f "read failed: ~s\n" websocket))
+          (if (websocket-socket-open? websocket) (loop '() #f)
+              (websocket-close websocket message)))))))
 
 ;; See Section 3 - WebSocket URIs
 (define (encrypted-websocket-scheme? uri)
@@ -313,9 +338,14 @@ KEY."
 (define (open-entropy-port)
   "Return an open input port to a reliable source of entropy for the
 current system."
-  ;; XXX: This works on GNU/Linux and OS X systems, but this isn't
-  ;; exactly portable.
-  (open-input-file "/dev/urandom"))
+  (if (file-exists? "/dev/urandom")
+      (open-input-file "/dev/urandom")
+      ;; XXX: This works as a fall back but this isn't exactly a
+      ;; reliable source of entropy.
+      (make-soft-port (vector (const #f) (const #f) (const #f)
+                              (lambda _ (let ((r (random 256))) (integer->char r)))
+                              (const #f)
+                              (const #t)) "r")))
 
 (define-method (websocket-close (websocket <websocket>))
   "Close the WebSocket connection for the client WEBSOCKET."