From: Christopher Allan Webber Date: Wed, 11 Jan 2017 16:54:14 +0000 (-0600) Subject: web: New actorified version of the web server. X-Git-Tag: v0.4.2~21 X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=975da18519fd07539ca94622a7070274a054198d;p=8sync.git web: New actorified version of the web server. * 8sync/systems/web.scm: New file. --- diff --git a/8sync/systems/web.scm b/8sync/systems/web.scm new file mode 100644 index 0000000..dc4fc2e --- /dev/null +++ b/8sync/systems/web.scm @@ -0,0 +1,184 @@ +;;; 8sync --- Asynchronous programming for Guile +;;; Copyright (C) 2017 Christopher Allan Webber +;;; +;;; Code (also under the LGPL) borrowed from fibers: +;;; Copyright (C) 2016 Andy Wingo +;;; and Guile: +;;; Copyright (C) 2010, 2011, 2012, 2015 Free Software Foundation, Inc. +;;; +;;; This file is part of 8sync. +;;; +;;; 8sync is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; 8sync is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with 8sync. If not, see . + + +(define-module (8sync systems web) + #: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 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) + (handler #:init-keyword #:handler + #:getter web-server-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-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)) diff --git a/Makefile.am b/Makefile.am index 8e03fb0..ff35426 100644 --- a/Makefile.am +++ b/Makefile.am @@ -49,6 +49,7 @@ SOURCES = \ 8sync/agenda.scm \ 8sync/repl.scm \ 8sync/systems/irc.scm \ + 8sync/systems/web.scm \ 8sync/actors.scm \ 8sync/debug.scm