X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=8sync%2Fsystems%2Fweb.scm;h=aaf329acd3065ea30e9757802b8e06c8b098d916;hb=1a0bb808ff75738d2ac3b62a76a405033b5d712b;hp=dc4fc2ef08da5b172dbf08a7064d331ce5ffba14;hpb=975da18519fd07539ca94622a7070274a054198d;p=8sync.git diff --git a/8sync/systems/web.scm b/8sync/systems/web.scm index dc4fc2e..aaf329a 100644 --- a/8sync/systems/web.scm +++ b/8sync/systems/web.scm @@ -1,10 +1,10 @@ ;;; 8sync --- Asynchronous programming for Guile -;;; Copyright (C) 2017 Christopher Allan Webber +;;; Copyright © 2017 Christopher Allan Webber ;;; ;;; Code (also under the LGPL) borrowed from fibers: -;;; Copyright (C) 2016 Andy Wingo +;;; Copyright © 2016 Andy Wingo ;;; and Guile: -;;; Copyright (C) 2010, 2011, 2012, 2015 Free Software Foundation, Inc. +;;; Copyright © 2010, 2011, 2012, 2015 Free Software Foundation, Inc. ;;; ;;; This file is part of 8sync. ;;; @@ -24,6 +24,7 @@ (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) @@ -32,46 +33,59 @@ #:use-module (web server) #:use-module (rnrs io ports) #:use-module (8sync) - #:export ()) + #:export ( + ;; @@: If we don't want to import these because of + ;; "conflicts" with other objects, we could just + ;; select only. + ;; Alternately we could move the crux of this into + ;; another module and just export , though + ;; that does feel a bit like overkill. + .host .family .port-num .addr .socket + .upgrade-paths .http-handler)) (define-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) - (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 )) + (slot-ref web-server 'upgrade-paths)) (define-method (initialize (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: @@ -98,21 +112,30 @@ (listen sock 1024) sock)) +(define-method (actor-init! (web-server )) + (<- (actor-id web-server) 'main-loop)) + +(define-method (actor-cleanup! (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))) @@ -125,60 +148,96 @@ 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 - (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-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))