X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Fsystems%2Fweb.scm;h=a6ee696e571a4826d4af20b52fdd0b1129b8187c;hp=ce1f6c74d3702fa8ddfcd080f9529c16bbe61657;hb=c7a6683e7ba2377909f37bc6dc11d49f43369191;hpb=4998e7a9fe3b303923d918cd6087633d5302274f

diff --git a/8sync/systems/web.scm b/8sync/systems/web.scm
index ce1f6c7..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)
@@ -43,35 +51,41 @@
 
   (host #:init-value #f
         #:init-keyword #:host
-        #:getter web-server-host)
+        #:getter .host)
   (family #:init-value AF_INET
           #:init-keyword #:family
-          #:getter web-server-family)
+          #:getter .family)
   (port-num #:init-value 8080
             #:init-keyword #:port
-            #:getter web-server-port-num)
+            #:getter .port-num)
   (addr #:init-keyword #:addr
-        #:accessor web-server-addr)
+        #:accessor .addr)
   (socket #:init-value #f
-          #:accessor web-server-socket)
-  (handler #:init-keyword #:handler
-           #:getter web-server-handler))
+          #:accessor .socket)
+  (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
   (when (not (slot-bound? web-server 'addr))
-    (set! (web-server-addr web-server)
-          (if (web-server-host web-server)
-              (inet-pton (web-server-family web-server)
-                         (web-server-host web-server))
+    (set! (.addr web-server)
+          (if (.host web-server)
+              (inet-pton (.family web-server)
+                         (.host web-server))
               INADDR_LOOPBACK)))
 
   ;; Set up the socket
-  (set! (web-server-socket web-server)
-        (make-default-socket (web-server-family web-server)
-                             (web-server-addr web-server)
-                             (web-server-port-num web-server)))
+  (set! (.socket web-server)
+        (make-default-socket (.family web-server)
+                             (.addr web-server)
+                             (.port-num web-server)))
 
   ;; This is borrowed from Guile's web server.
   ;; Andy Wingo added the line with this commit:
@@ -102,7 +116,7 @@
   "The main loop on our socket.  Keep accepting new clients as long
 as we're alive."
   (while #t
-    (match (accept (web-server-socket web-server))
+    (match (accept (.socket web-server))
       ((client . sockaddr)
        ;; From "HOP, A Fast Server for the Diffuse Web", Serrano.
        (setsockopt client SOL_SOCKET SO_SNDBUF (* 12 1024))
@@ -125,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
@@ -147,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)
@@ -171,14 +212,14 @@ as we're alive."
 (define (web-server-handle-request web-server message
                                    request body)
   (receive (response body)
-      ((web-server-handler web-server) request body)
+      ((.http-handler web-server) request body)
     (receive (response body)
         (sanitize-response request response body)
       (<-reply message response body))))
 
 (define (web-server-cleanup web-server message)
   ;; @@: Should we close any pending requests too?
-  (close (web-server-socket web-server)))
+  (close (.socket web-server)))
 
 (define (web-server-shutdown web-server message)
   (self-destruct web-server))