From: Christopher Allan Webber <cwebber@dustycloud.org>
Date: Sun, 15 Jan 2017 21:27:12 +0000 (-0600)
Subject: websocket + http actor starting to work
X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=d44e92b54f9e31956cd7b7e58ff22abcefd807ec;p=8sync.git

websocket + http actor starting to work
---

diff --git a/8sync/systems/web.scm b/8sync/systems/web.scm
index 82ed4d2..a6ee696 100644
--- a/8sync/systems/web.scm
+++ b/8sync/systems/web.scm
@@ -32,7 +32,15 @@
   #:use-module (web server)
   #:use-module (rnrs io ports)
   #:use-module (8sync)
-  #:export (<web-server>))
+  #:export (<web-server>
+            ;; @@: If we don't want to import these because of
+            ;;   "conflicts" with other objects, we could just
+            ;;   select <web-server> only.
+            ;;   Alternately we could move the crux of this into
+            ;;   another module and just export <web-server>, though
+            ;;   that does feel a bit like overkill.
+            .host .family .port-num .addr .socket
+            .upgrade-paths .http-handler))
 
 (define-actor <web-server> (<actor>)
   ((*init* web-server-socket-loop)
@@ -54,11 +62,15 @@
         #:accessor .addr)
   (socket #:init-value #f
           #:accessor .socket)
-  (upgrade #:init-value '()
-           #:allocation #:each-subclass)
+  (upgrade-paths #:init-value '()
+                 #:allocation #:each-subclass)
   (http-handler #:init-keyword #:http-handler
                 #:getter .http-handler))
 
+;; Define getter externally so it works even if we subclass
+(define-method (.upgrade-paths (web-server <web-server>))
+  (slot-ref web-server 'upgrade-paths))
+
 (define-method (initialize (web-server <web-server>) init-args)
   (next-method)
   ;; Make sure the addr is set up
@@ -127,6 +139,23 @@ as we're alive."
               ((0) (memq 'keep-alive (response-connection response)))))
            (else #f)))))
 
+(define (maybe-upgrade-request web-server request body)
+  (define upgrade-paths (.upgrade-paths web-server))
+  ;; A request can specify multiple values to the "Upgrade"
+  ;; field, so we slook to see if we have an applicable option,
+  ;; in order.
+  ;; Note that we'll only handle one... we *don't* "compose"
+  ;; upgrades.
+  (let loop ((upgrades (request-upgrade request)))
+    (if (eq? upgrades '())
+        #f ; Shouldn't upgrade
+        (match (assoc (car upgrades) upgrade-paths)
+          ;; Yes, upgrade with this method
+          ((_ . upgrade-proc)
+           upgrade-proc)
+          ;; Keep looking...
+          (#f (loop (cdr upgrades)))))))
+
 (define (web-server-client-loop web-server message client)
   "Read request(s) from a client and pass off to the handler."
   (with-throw-handler #t
@@ -149,12 +178,22 @@ as we're alive."
             (lambda ()
               (let* ((request (read-request client))
                      (body (read-request-body request)))
-                (call-with-message
-                 ;; TODO: Add error handling in case we get an error
-                 ;;   response
-                 (<-wait (actor-id web-server) 'handle-request
-                         request body)
-                 respond-and-maybe-continue)))
+                (cond
+                 ;; Should we "upgrade" the protocol?
+                 ;; Doing so "breaks out" of this loop, possibly into a new one
+                 ((maybe-upgrade-request web-server request body) =>
+                  (lambda (upgrade)
+                    ;; TODO: this isn't great because we're in this catch,
+                    ;;   which doesn't make sense once we've "upgraded"
+                    ;;   since we might not "respond" in the same way anymore.
+                    (upgrade web-server client request body)))
+                 (else
+                  (call-with-message
+                   ;; TODO: Add error handling in case we get an error
+                   ;;   response
+                   (<-wait (actor-id web-server) 'handle-request
+                           request body)
+                   respond-and-maybe-continue)))))
             (lambda (key . args)
               (display "While reading request:\n" (current-error-port))
               (print-exception (current-error-port) #f key args)
diff --git a/8sync/systems/websocket/server.scm b/8sync/systems/websocket/server.scm
index 080f0a5..dd8db94 100644
--- 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,12 +57,15 @@ string."
                                 (connection . (upgrade))
                                 (sec-websocket-accept . ,accept-key)))))
 
-(define-actor <websocket-server> (<web-server>)
-  ((new-client websocket-client-loop))
+(define-class <websocket-server> (<web-server>)
+  (upgrade-paths #:init-value `(("websocket" .
+                                 ,(wrap-apply websocket-client-loop)))
+                 #:allocation #:each-subclass
+                 #:accessor .upgrade-paths)
   (websocket-handler #:init-keyword #:websocket-handler
                      #:getter .websocket-handler))
 
-(define (websocket-client-loop websocket-server message client)
+(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."
@@ -77,7 +81,6 @@ called for each complete message that is received."
                        (make-binary-frame result))
                       ((not result)
                        #f))))
-
       (when response
         (write-frame response client))))
 
@@ -89,8 +92,7 @@ called for each complete message that is received."
   (setvbuf client 'none)
 
   ;; 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 '())