dispatching to websocket handlers

[8sync.git] / 8sync / systems / websocket / server.scm

diff --git a/8sync/systems/websocket/server.scm b/8sync/systems/websocket/server.scm
index 080f0a5949748847541ebd255fd935f010bed09c..04e961c25b2997feecb65b32eae0024f2631b674 100644 (file)
--- a/8sync/systems/websocket/server.scm
+++ b/8sync/systems/websocket/server.scm
@@ -36,7 +36,8 @@
   #:use-module (8sync systems web)
   #:use-module (8sync systems websocket frame)
   #:use-module (8sync systems websocket utils)
-  #:export (<websocket-server>))
+  #:export (<websocket-server>
+            .websocket-handler))
 
 ;; See section 4.2 for explanation of the handshake.
 (define (read-handshake-request client-socket)
@@ -56,41 +57,64 @@ string."
                                 (connection . (upgrade))
                                 (sec-websocket-accept . ,accept-key)))))
 
+(define no-op (const #f))
+
 (define-actor <websocket-server> (<web-server>)
-  ((new-client websocket-client-loop))
-  (websocket-handler #:init-keyword #:websocket-handler
-                     #:getter .websocket-handler))
+  ((ws-send websocket-server-send))
+  (upgrade-paths #:init-value `(("websocket" .
+                                 ,(wrap-apply websocket-client-loop)))
+                 #:allocation #:each-subclass
+                 #:accessor .upgrade-paths)
+
+  ;; active websocket connections
+  (ws-clients #:init-thunk make-hash-table
+              #:accessor .ws-clients)
 
-(define (websocket-client-loop websocket-server message client)
+  (on-ws-message #:init-keyword #:on-ws-message 
+                 #:getter .on-ws-message)
+  (on-ws-client-connect #:init-keyword #:on-ws-client-connect
+                        #:init-value no-op
+                        #:getter .on-ws-client-connect)
+  (on-ws-client-disconnect #:init-keyword #:on-ws-client-disconnect
+                           #:init-value no-op
+                           #:getter .on-ws-client-disconnect))
+
+(define (websocket-client-loop websocket-server client request body)
   "Serve client connected via CLIENT by performing the HTTP
 handshake and listening for control and data frames.  HANDLER is
 called for each complete message that is received."
+  ;; TODO: We'll also want to handle stuff like the sub-protocol.
   (define (handle-data-frame type data)
-    (let* ((result   ((.websocket-handler websocket-server)
-                      (match type
-                        ('text   (utf8->string data))
-                        ('binary data))))
-           (response (cond
-                      ((string? result)
-                       (make-text-frame result))
-                      ((bytevector? result)
-                       (make-binary-frame result))
-                      ((not result)
-                       #f))))
-
-      (when response
-        (write-frame response client))))
+    ((.on-ws-message websocket-server)
+     websocket-server client-id
+     (match type
+       ('text   (utf8->string data))
+       ('binary data))))
 
   (define (read-frame-maybe)
     (and (not (eof-object? (lookahead-u8 client)))
          (read-frame client)))
 
+  ;; Allows other actors to send things to this specific client
+  ;; @@: We probably could just increment a counter...
+  (define client-id (big-random-number))
+
+  (define (close-down)
+    (close-port client)
+    (hash-remove! (.ws-clients websocket-server) client-id)
+    ((.on-ws-client-disconnect websocket-server)
+     websocket-server client-id))
+
+  (hash-set! (.ws-clients websocket-server) client-id client)
+
   ;; Disable buffering for websockets
   (setvbuf client 'none)
 
+  ((.on-ws-client-connect websocket-server)
+   websocket-server client-id)
+
   ;; Perform the HTTP handshake and upgrade to WebSocket protocol.
-  (let* ((request (read-handshake-request client))
-         (client-key (assoc-ref (request-headers request) 'sec-websocket-key))
+  (let* ((client-key (assoc-ref (request-headers request) 'sec-websocket-key))
          (response (make-handshake-response client-key)))
     (write-response response client)
     (let loop ((fragments '())
@@ -99,7 +123,7 @@ called for each complete message that is received."
         (cond
          ;; EOF - port is closed.
          ((not frame)
-          (close-port client))
+          (close-down))
          ;; Per section 5.4, control frames may appear interspersed
          ;; along with a fragmented message.
          ((close-frame? frame)
@@ -108,7 +132,7 @@ called for each complete message that is received."
           ;; longer be listening.
           (false-if-exception
            (write-frame (make-close-frame (frame-data frame)) client))
-          (close-port client))
+          (close-down))
          ((ping-frame? frame)
           ;; Per section 5.5.3, a pong frame must include the exact
           ;; same data as the ping frame.
@@ -126,3 +150,19 @@ called for each complete message that is received."
          ((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))))