X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=8sync%2Fsystems%2Fwebsocket%2Fserver.scm;h=7a7526d054f8a4fadb645d6448eedc84d887ccdb;hb=0f7daa4787860cbbc739a51140fb8257b7fc4fef;hp=97645bb8ef3490a0b5b6f0e06c4b235b1e252925;hpb=c7a6683e7ba2377909f37bc6dc11d49f43369191;p=8sync.git

diff --git a/8sync/systems/websocket/server.scm b/8sync/systems/websocket/server.scm
index 97645bb..7a7526d 100644
--- a/8sync/systems/websocket/server.scm
+++ b/8sync/systems/websocket/server.scm
@@ -1,5 +1,6 @@
 ;;; guile-websocket --- WebSocket client/server
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
 ;;;
 ;;; This file is part of guile-websocket.
 ;;;
@@ -68,7 +69,7 @@ string."
 (define-actor <websocket-server> (<web-server>)
   ((ws-send websocket-server-send))
   (upgrade-paths #:init-value `(("websocket" .
-                                 ,(wrap-apply websocket-client-loop)))
+                                 ,(live-wrap websocket-client-loop)))
                  #:allocation #:each-subclass
                  #:accessor .upgrade-paths)
 
@@ -124,56 +125,61 @@ called for each complete message that is received."
   ((.on-ws-client-connect websocket-server)
    websocket-server client-id)
 
-  ;; Perform the HTTP handshake and upgrade to WebSocket protocol.
-  (let* ((client-key (assoc-ref (request-headers request) 'sec-websocket-key))
-         (response (make-handshake-response client-key)))
-    (write-response response client)
-    (let loop ((fragments '())
-               (type #f))
-      (let ((frame (read-frame-maybe)))
-        (cond
-         ;; EOF - port is closed.
-         ((not 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
-          ;; client before closing the socket.  The client may no
-          ;; longer be listening.
-          (false-if-exception
-           (write-frame (make-close-frame (frame-data frame)) client))
-          (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)) client)
-          (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 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)))))))
+  (with-actor-nonblocking-ports
+   (lambda ()
+     ;; Perform the HTTP handshake and upgrade to WebSocket protocol.
+     (let* ((client-key (assoc-ref (request-headers request) 'sec-websocket-key))
+            (response (make-handshake-response client-key)))
+       (write-response response client)
+       (let loop ((fragments '())
+                  (type #f))
+         (let ((frame (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
+             ;; client before closing the socket.  The client may no
+             ;; longer be listening.
+             (false-if-exception
+              (write-frame (make-close-frame (frame-data frame)) client))
+             (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)) client)
+             (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 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)))))))))
 
 (define (websocket-server-send websocket-server message client-id data)
-  (cond ((hash-ref (.ws-clients websocket-server) client-id) =>
-         (lambda (client)
-           (write-frame
-            (cond ((string? data)
-                   (make-text-frame data))
-                  ((bytevector? data)
-                   (make-binary-frame data)))
-            client)
-           ;; ok is like success, amirite
-           (<-reply message 'ok)))
-        (else
-         ;; No such client with that id.
-         ;; Either it closed, or it was never there.
-         (<-reply message 'client-gone))))
+  (with-actor-nonblocking-ports
+   (lambda ()
+     (cond ((hash-ref (.ws-clients websocket-server) client-id) =>
+            (lambda (client)
+              (write-frame
+               (cond ((string? data)
+                      (make-text-frame data))
+                     ((bytevector? data)
+                      (make-binary-frame data)))
+               client)
+              ;; ok is like success, amirite
+              'ok))
+           ;; No such client with that id.
+           ;; Either it closed, or it was never there.
+           (else 'client-gone)))))