X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Fsystems%2Fweb.scm;h=597fd008574be22775837f9fe8695b1e6e12dc9c;hp=2dcaf5167f1e1c2ffaa1cfa33937dd2fcf5b3ad0;hb=f82b19034aa588a744fff713416bd914778681eb;hpb=c4732ac1753554c61613b906166efe6ace38200a diff --git a/8sync/systems/web.scm b/8sync/systems/web.scm index 2dcaf51..597fd00 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,166 @@ ;;; 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 ()) + +(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 web-server-host) + (family #:init-value AF_INET + #:init-keyword #:family + #:getter web-server-family) + (port-num #:init-value 8080 + #:init-keyword #:port + #:getter web-server-port-num) + (addr #:init-keyword #:addr + #:accessor web-server-addr) + (socket #:init-value #f + #:accessor web-server-socket) + (upgrade #:init-value '() + #:allocation #:each-subclass) + (http-handler #:init-keyword #:http-handler + #:getter web-server-http-handler)) + +(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)) + 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))) + + ;; 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 (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))))) + +(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 (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)))))) + +(define (web-server-handle-request web-server message + request body) + (receive (response body) + ((web-server-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))) + +(define (web-server-shutdown web-server message) + (self-destruct web-server))