X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Fsystems%2Fweb.scm;h=a6ee696e571a4826d4af20b52fdd0b1129b8187c;hp=602e06f827f08ce835cf02ed8eb50678a4e07fbc;hb=c7a6683e7ba2377909f37bc6dc11d49f43369191;hpb=8736abc829c650971686d2d840d4fdacd970edd8 diff --git a/8sync/systems/web.scm b/8sync/systems/web.scm index 602e06f..a6ee696 100644 --- a/8sync/systems/web.scm +++ b/8sync/systems/web.scm @@ -1,9 +1,10 @@ -#!/usr/bin/guile \ --e main -s -!# - ;;; 8sync --- Asynchronous programming for Guile -;;; Copyright (C) 2015 Christopher Allan Webber +;;; Copyright © 2017 Christopher Allan Webber +;;; +;;; Code (also under the LGPL) borrowed from fibers: +;;; Copyright © 2016 Andy Wingo +;;; and Guile: +;;; Copyright © 2010, 2011, 2012, 2015 Free Software Foundation, Inc. ;;; ;;; This file is part of 8sync. ;;; @@ -20,157 +21,205 @@ ;;; You should have received a copy of the GNU Lesser General Public ;;; License along with 8sync. If not, see . -;; This is a very preliminary web module. (define-module (8sync systems web) - #:use-module (web server) + #:use-module (oop goops) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (web http) #:use-module (web request) #:use-module (web response) - #:use-module (web uri) - #:use-module (8sync agenda) - #:use-module (8sync repl) - #:use-module (ice-9 receive) - #:use-module (ice-9 match) - #:export (http-server-socket - receive-http-conn - simple-webdemo - make-web-demo-cli)) - -(define (hello-world-handler request request-body) - (values '((content-type . (text/plain))) - "Hello world!")) - -(define* (http-server-socket #:key - (host #f) - (family AF_INET) - (addr (if host - (inet-pton family host) - INADDR_LOOPBACK)) - (port 8080) - (socket - ((@@ (web server http) make-default-socket) - family addr port))) - (listen socket 128) - ;;; This is used in Guile's http server under the commit: - ;;; commit a0ad8ad16c14adbf13e0ead3dafd833fb3c8f0d3 - ;;; Author: Andy Wingo - ;;; Date: Mon Nov 29 13:00:43 2010 +0100 - ;;; - ;;; http web server impl ignores SIGPIPE - ;;; - ;;; * module/web/server/http.scm (http-open): Ignore SIGPIPE. Keeps the - ;;; server from dying in some circumstances. - ;; (sigaction SIGPIPE SIG_IGN) - ;;; Will this break other things that use pipes for us though? - - ;; Throw a system-error rather than block on an (accept) - ;; that has nothing to do - (fcntl socket F_SETFL - (logior O_NONBLOCK - (fcntl socket F_GETFL))) - socket) - - -(define* (accept-connection-gracefully socket #:key complain) - "Try to accept a connection, but if there's nothing there, -don't totally failboat" - (catch 'system-error - (lambda () (accept socket)) - ;; Maybe should catch the more specific error: - ;; (system-error "accept" "~A" ("Resource temporarily unavailable") (11)) - (lambda args - (if complain - (display "Gracefully handled no connection to accept\n" - (current-error-port))) - #f))) - -(define (receive-http-conn handler) - (lambda (server-socket) - (let ((conn-pair (accept-connection-gracefully - server-socket #:complain #t))) - (match conn-pair - ((client-conn . socket-address) - (define (close-and-dequeue) - (close client-conn) - (%8sync-port-remove client-conn)) - - (catch - #t - (lambda () - (let* ((request (read-request client-conn)) - (request-body (read-request-body request))) - (call-with-values - (lambda () - (call-with-values - (lambda () - ;; @@: Is it useful to wrap this in %8sync-run? - ;; It's more indirection but might give breathing - ;; room to other requests... - (handler request request-body)) - (lambda return-values - (match return-values - ((response response-body) - (sanitize-response request response response-body)) - (_ (throw 'invalid-http-response - "Expected values of (response response-body) but didn't get 'em" - return-values)))))) - (lambda (response response-body) - (begin - (write-response-body - (write-response response client-conn) - response-body) - ;; TODO: We might NOT want to close here! - ;; Eg, keep-alive requests. See keep-alive? in guile's - ;; (@@ (web server http) http-write) - (close-and-dequeue)))))) - (lambda (key . args) - (display ":(\n") - (close-and-dequeue) - ;; re-raise exception - (apply throw key args)))) - ;; If we get a #f back, there was nothing to do - (#f #f))))) - -(define (install-http-socket socket handler) - (make-port-request socket #:read (receive-http-conn handler))) - -;; Kinda junky since dynamic-wind and delimited continuations -;; seem to not really get along... - -(define-syntax-rule (with-socket-as make-socket socket-name - body ...) - (let ((socket-name make-socket)) - (dynamic-wind - (const #f) - (lambda () - body ...) - (lambda () - (close socket-name))))) - -(define default-handler (wrap-apply hello-world-handler)) - -(define* (run-simple-webserver #:key - (handler default-handler) - (coop-repl #f)) - (display "Running on http://127.0.0.1:8080/\n") - (with-socket-as - (http-server-socket) server-socket - (let* ((q (make-q* - (wrap (install-http-socket server-socket - handler)))) - (agenda (make-agenda - #:queue q - #:pre-unwind-handler print-error-and-continue))) - (if coop-repl - (spawn-and-queue-repl-server! agenda)) - (start-agenda agenda)))) - -(define* (make-web-demo-cli #:key - (listen #t) - (handler default-handler)) - (define (main args) - (run-simple-webserver #:coop-repl listen - #:handler handler)) - main) - -(define main (make-web-demo-cli)) + #:use-module (web server) + #:use-module (rnrs io ports) + #:use-module (8sync) + #: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) + (shutdown web-server-shutdown) + (new-client web-server-client-loop) + (handle-request web-server-handle-request)) + + (host #:init-value #f + #:init-keyword #:host + #:getter .host) + (family #:init-value AF_INET + #:init-keyword #:family + #:getter .family) + (port-num #:init-value 8080 + #:init-keyword #:port + #:getter .port-num) + (addr #:init-keyword #:addr + #:accessor .addr) + (socket #:init-value #f + #: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! (.addr web-server) + (if (.host web-server) + (inet-pton (.family web-server) + (.host web-server)) + INADDR_LOOPBACK))) + + ;; Set up the socket + (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: + ;; * module/web/server/http.scm (http-open): Ignore SIGPIPE. Keeps the + ;; server from dying in some circumstances. + (sigaction SIGPIPE SIG_IGN)) + +;; @@: Borrowed from Guile itself / Fibers + +(define (set-nonblocking! port) + (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL))) + (setvbuf port 'block 1024)) + +(define (make-default-socket family addr port) + (let ((sock (socket PF_INET SOCK_STREAM 0))) + (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) + (fcntl sock F_SETFD FD_CLOEXEC) + (bind sock family addr port) + (set-nonblocking! sock) + ;; We use a large backlog by default. If the server is suddenly hit + ;; with a number of connections on a small backlog, clients won't + ;; receive confirmation for their SYN, leading them to retry -- + ;; probably successfully, but with a large latency. + (listen sock 1024) + sock)) + +(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 (.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))) + (and (or (< (response-code response) 400) + (= (response-code response) 404)) + (case (car v) + ((1) + (case (cdr v) + ((1) (not (memq 'close (response-connection 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))) + (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) + (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)))))) + +(define (web-server-handle-request web-server message + request body) + (receive (response 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 (.socket web-server))) + +(define (web-server-shutdown web-server message) + (self-destruct web-server))