#: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)
(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:
"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))
((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
(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)
(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))
projects / 8sync.git / blobdiff