(define-module (8sync systems web)
#:use-module (oop goops)
+ #:use-module (ice-9 control)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (web http)
#: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)
- (*cleanup* web-server-cleanup)
+ ((main-loop web-server-socket-loop)
(shutdown web-server-shutdown)
(new-client web-server-client-loop)
(handle-request web-server-handle-request))
(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)
- (upgrade #:init-value '()
- #:allocation #:each-subclass)
+ #:accessor .socket)
+ (upgrade-paths #:init-value '()
+ #:allocation #:each-subclass)
(http-handler #:init-keyword #:http-handler
- #:getter web-server-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:
(listen sock 1024)
sock))
+(define-method (actor-init! (web-server <web-server>))
+ (<- (actor-id web-server) 'main-loop))
+
+(define-method (actor-cleanup! (web-server <web-server>))
+ ;; @@: Should we close any pending requests too?
+ (close (.socket web-server)))
+
(define (web-server-socket-loop web-server message)
"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))
- ((client . sockaddr)
- ;; From "HOP, A Fast Server for the Diffuse Web", Serrano.
- (setsockopt client SOL_SOCKET SO_SNDBUF (* 12 1024))
- (set-nonblocking! client)
- ;; Always disable Nagle's algorithm, as we handle buffering
- ;; ourselves. Ignore exceptions if it's not a TCP port, or
- ;; TCP_NODELAY is not defined on this platform.
- (false-if-exception
- (setsockopt client IPPROTO_TCP TCP_NODELAY 0))
- (<- (actor-id web-server) 'new-client client)))))
+ (with-actor-nonblocking-ports
+ (lambda ()
+ (while #t
+ (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))
+ (set-nonblocking! client)
+ ;; Always disable Nagle's algorithm, as we handle buffering
+ ;; ourselves. Ignore exceptions if it's not a TCP port, or
+ ;; TCP_NODELAY is not defined on this platform.
+ (false-if-exception
+ (setsockopt client IPPROTO_TCP TCP_NODELAY 0))
+ (<- (actor-id web-server) 'new-client client)))))))
(define (keep-alive? response)
(let ((v (response-version response)))
((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 loop ()
- (define (respond-and-maybe-continue _ response body)
- (write-response response client)
- (when body
- (put-bytevector client body))
- (force-output client)
- (if (and (keep-alive? response)
- (not (eof-object? (peek-char client))))
- (loop)
- (close-port client)))
- (cond
- ((eof-object? (lookahead-u8 client))
- (close-port client))
- (else
- (catch #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)))
- (lambda (key . args)
- (display "While reading request:\n" (current-error-port))
- (print-exception (current-error-port) #f key args)
- (respond-and-maybe-continue
- #f ;; ignored, there is no message
- (build-response #:version '(1 . 0) #:code 400
- #:headers '((content-length . 0)))
- #vu8())))))))
- (lambda (k . args)
- (catch #t
- (lambda () (close-port client))
- (lambda (k . args)
- (display "While closing port:\n" (current-error-port))
- (print-exception (current-error-port) #f k args))))))
+ (with-actor-nonblocking-ports
+ (lambda ()
+ (with-throw-handler #t
+ (lambda ()
+ (let loop ()
+ (define (respond-and-maybe-continue response body)
+ (write-response response client)
+ (when body
+ (put-bytevector client body))
+ (force-output client)
+ (if (and (keep-alive? response)
+ (not (eof-object? (peek-char client))))
+ (loop)
+ (close-port client)))
+ (cond
+ ((eof-object? (lookahead-u8 client))
+ (close-port client))
+ (else
+ (call/ec
+ (lambda (return)
+ (define (read-with-catch thunk)
+ (catch #t
+ thunk
+ (lambda _
+ (return
+ (false-if-exception
+ (respond-and-maybe-continue
+ (build-response #:version '(1 . 0) #:code 400
+ #:headers '((content-length . 0)))
+ #vu8()))))
+ (let ((err (current-error-port)))
+ (lambda (key . args)
+ (false-if-exception
+ (let ((stack (make-stack #t 4)))
+ (display "While reading request:\n" err)
+ ;; @@: Maybe comment this out or make it optional?
+ (display-backtrace stack err)
+ (print-exception err (stack-ref stack 0) key args)
+ (newline err)))))))
+ (let* ((request (read-with-catch
+ (lambda () (read-request client))))
+ (body (read-with-catch
+ (lambda () (read-request-body request)))))
+ (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)
+ (upgrade web-server client request body)))
+ (else
+ (call-with-values
+ (lambda ()
+ ;; 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 (k . args)
+ (catch #t
+ (lambda () (close-port client))
+ (lambda (k . args)
+ (display "While closing port:\n" (current-error-port))
+ (print-exception (current-error-port) #f k args))))))))
(define (web-server-handle-request web-server message
request body)
(receive (response body)
- ((web-server-http-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)))
+ (values response body))))
(define (web-server-shutdown web-server message)
(self-destruct web-server))
projects / 8sync.git / blobdiff