From 79ef79ee348401917e220170454b0d2c502060b9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 12 Nov 2010 12:07:24 +0100 Subject: [PATCH] add generic web server with http-over-tcp backend * module/web/server.scm: New generic web server module, with support for different backends. An HTTP-over-TCP backend is the only one included with Guile, though one can imagine FastCGI, mod-lisp, mongrel2/0mq etc backends as well. * module/web/server/http.scm: The aforementioned HTTP backend. --- module/Makefile.am | 2 + module/web/server.scm | 242 +++++++++++++++++++++++++++++++++++++ module/web/server/http.scm | 123 +++++++++++++++++++ 3 files changed, 367 insertions(+) create mode 100644 module/web/server.scm create mode 100644 module/web/server/http.scm diff --git a/module/Makefile.am b/module/Makefile.am index f17e225bb..5ee3a46e5 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -352,6 +352,8 @@ WEB_SOURCES = \ web/http.scm \ web/request.scm \ web/response.scm \ + web/server.scm \ + web/server/http.scm \ web/toy-server.scm \ web/uri.scm diff --git a/module/web/server.scm b/module/web/server.scm new file mode 100644 index 000000000..2e7ad0c50 --- /dev/null +++ b/module/web/server.scm @@ -0,0 +1,242 @@ +;;; Web server + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; This library 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. +;; +;; This library 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 this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Commentary: +;;; +;;; (web server) is a generic web server interface, along with a main +;;; loop implementation for web servers controlled by Guile. +;;; +;;; The lowest layer is the object, which defines a set of +;;; hooks to open a server, read a request from a client, write a +;;; response to a client, and close a server. These hooks -- open, +;;; read, write, and close, respectively -- are bound together in a +;;; object. Procedures in this module take a +;;; object, if needed. +;;; +;;; A may also be looked up by name. If you pass the +;;; `http' symbol to `run-server', Guile looks for a variable named +;;; `http' in the `(web server http)' module, which should be bound to a +;;; object. Such a binding is made by instantiation of +;;; the `define-server-impl' syntax. In this way the run-server loop can +;;; automatically load other backends if available. +;;; +;;; The life cycle of a server goes as follows: +;;; +;;; * The `open' hook is called, to open the server. `open' takes 0 or +;;; more arguments, depending on the backend, and returns an opaque +;;; server socket object, or signals an error. +;;; +;;; * The `read' hook is called, to read a request from a new client. +;;; The `read' hook takes two arguments: the server socket, and a +;;; list of keep-alive clients. It should return four values: the +;;; new list of keep-alive clients, an opaque client socket, the +;;; request, and the request body. The request should be a +;;; `' object, from `(web request)'. The body should be a +;;; string or a bytevector, or `#f' if there is no body. +;;; +;;; The keep-alive list is used when selecting a new request. You +;;; can either serve an old client or serve a new client; and some +;;; old clients might close their connections while you are waiting. +;;; The `read' hook returns a new keep-alive set to account for old +;;; clients going away, and for read errors on old clients. +;;; +;;; If the read failed, the `read' hook may return #f for the client +;;; socket, request, and body. +;;; +;;; * A user-provided handler procedure is called, with the request +;;; and body as its arguments. The handler should return two +;;; values: the response, as a `' record from `(web +;;; response)', and the response body as a string, bytevector, or +;;; `#f' if not present. We also allow the reponse to be simply an +;;; alist of headers, in which case a default response object is +;;; constructed with those headers. +;;; +;;; * The `write' hook is called with three arguments: the client +;;; socket, the response, and the body. The `write' hook may return +;;; #f to indicate that the connection was closed. If `write' +;;; returns a true value, it will be consed onto the keep-alive +;;; list. +;;; +;;; * At this point the request handling is complete. For a loop, we +;;; loop back with the new keep-alive list, and try to read a new +;;; request. +;;; +;;; * If the user interrupts the loop, the `close' hook is called on +;;; the server socket. +;;; +;;; Code: + +(define-module (web server) + #:use-module (srfi srfi-9) + #:use-module (rnrs bytevectors) + #:use-module (web request) + #:use-module (web response) + #:use-module (system repl error-handling) + #:use-module (ice-9 control) + #:export (define-server-impl + lookup-server-impl + open-server + read-client + handle-request + sanitize-response + write-client + close-server + serve-one-client + run-server)) + +(define-record-type server-impl + (make-server-impl name open read write close) + server-impl? + (name server-impl-name) + (open server-impl-open) + (read server-impl-read) + (write server-impl-write) + (close server-impl-close)) + +(define-syntax define-server-impl + (syntax-rules () + ((_ name open read write close) + (define name + (make-server-impl 'name open read write close))))) + +(define (lookup-server-impl impl) + (cond + ((server-impl? impl) impl) + ((symbol? impl) + (let ((impl (module-ref (resolve-module `(web server ,impl)) impl))) + (if (server-impl? impl) + impl + (error "expected a server impl in module" `(web server ,impl))))) + (else + (error "expected a server-impl or a symbol" impl)))) + +;; -> server +(define (open-server impl open-params) + (apply (server-impl-open impl) open-params)) + +;; -> (keep-alive client request body | keep-alive #f #f #f) +(define (read-client impl server keep-alive) + (call-with-error-handling + (lambda () + ((server-impl-read impl) server keep-alive)) + #:pass-keys '(quit interrupt) + #:on-error (if (batch-mode?) 'pass 'debug) + #:post-error + (lambda (k . args) + (warn "Error while accepting client" k args) + (values keep-alive #f #f #f #f)))) + +;; -> response body state ... +(define (handle-request handler request body . state) + (call-with-error-handling + (lambda () + (with-stack-and-prompt + (lambda () + (apply handler request body state)))) + #:pass-keys '(quit interrupt) + #:on-error (if (batch-mode?) 'pass 'debug) + #:post-error + (lambda (k . args) + (warn "Error handling request" k args) + (apply values (build-response #:code 500) #f state)))) + +;; -> response body +(define (sanitize-response request response body) + (values response body)) + +;; -> (#f | client) +(define (write-client impl server client response body) + (call-with-error-handling + (lambda () + ((server-impl-write impl) server client response body)) + #:pass-keys '(quit interrupt) + #:on-error (if (batch-mode?) 'pass 'debug) + #:post-error + (lambda (k . args) + (warn "Error while writing response" k args) + #f))) + +;; -> unspecified values +(define (close-server impl server) + ((server-impl-close impl) server)) + +(define call-with-sigint + (if (not (provided? 'posix)) + (lambda (thunk handler-thunk) (thunk)) + (lambda (thunk handler-thunk) + (let ((handler #f)) + (catch 'interrupt + (lambda () + (dynamic-wind + (lambda () + (set! handler + (sigaction SIGINT (lambda (sig) (throw 'interrupt))))) + thunk + (lambda () + (if handler + ;; restore Scheme handler, SIG_IGN or SIG_DFL. + (sigaction SIGINT (car handler) (cdr handler)) + ;; restore original C handler. + (sigaction SIGINT #f))))) + (lambda (k . _) (handler-thunk))))))) + +(define (with-stack-and-prompt thunk) + (call-with-prompt (default-prompt-tag) + (lambda () (start-stack #t (thunk))) + (lambda (k proc) + (with-stack-and-prompt (lambda () (proc k)))))) + +(define (and-cons x xs) + (if x (cons x xs) xs)) + +;; -> new keep-alive new-state +(define (serve-one-client handler impl server keep-alive state) + (call-with-values + (lambda () + (read-client impl server keep-alive)) + (lambda (keep-alive client request body) + (if client + (call-with-values + (lambda () + (apply handle-request handler request body state)) + (lambda (response body . state) + (call-with-values (lambda () + (sanitize-response request response body)) + (lambda (response body) + (values + (and-cons (write-client impl server client response body) + keep-alive) + state))))) + (values keep-alive state))))) + +(define* (run-server handler #:optional (impl 'http) (open-params '()) + . state) + (let* ((impl (lookup-server-impl impl)) + (server (open-server impl open-params))) + (call-with-sigint + (lambda () + (let lp ((keep-alive '()) (state state)) + (call-with-values + (lambda () + (serve-one-client handler impl server keep-alive state)) + (lambda (new-keep-alive new-state) + (lp new-keep-alive new-state))))) + (lambda () + (close-server impl server) + (values))))) diff --git a/module/web/server/http.scm b/module/web/server/http.scm new file mode 100644 index 000000000..373017ed0 --- /dev/null +++ b/module/web/server/http.scm @@ -0,0 +1,123 @@ +;;; Web I/O: HTTP + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; This library 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. +;; +;; This library 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 this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Code: + +(define-module (web server http) + #:use-module ((srfi srfi-1) #:select (fold)) + #:use-module (rnrs bytevectors) + #:use-module (web request) + #:use-module (web response) + #:use-module (web server) + #:use-module (system repl error-handling)) + + +(define (make-default-socket family addr port) + (let ((sock (socket PF_INET SOCK_STREAM 0))) + (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) + (bind sock family addr port) + sock)) + +;; -> server +(define* (http-open #:key + (host #f) + (family AF_INET) + (addr (if host + (inet-pton family host) + INADDR_LOOPBACK)) + (port 8080) + (socket (make-default-socket family addr port))) + (listen socket 5) + socket) + +;; -> (keep-alive client request body | keep-alive #f #f #f) +(define (http-read server keep-alive) + (call-with-values (lambda () + (let ((ports (cons server keep-alive))) + (apply values (select ports '() ports)))) + (lambda (readable writable except) + (cond + ((pair? except) + (values (fold (lambda (p keep-alive) + (close-port p) + (if (eq? p server) + (throw 'interrupt) + (delq p keep-alive))) + keep-alive + except) + #f #f #f)) + ((memq server readable) + ;; FIXME: meta to read-request + (let* ((client (accept server)) + (req (read-request (car client))) + (body-str (read-request-body/latin-1 req))) + (values keep-alive (car client) req body-str))) + ((pair? readable) + ;; FIXME: preserve meta for keep-alive + (let* ((p (car readable)) + (keep-alive (delq p keep-alive))) + (if (eof-object? (peek-char p)) + (begin + (close-port p) + (values keep-alive #f #f #f)) + (call-with-error-handling + (lambda () + (let* ((req (read-request p)) + (body-str (read-request-body/latin-1 req))) + (values keep-alive p req body-str))) + #:pass-keys '(quit interrupt) + #:on-error (if (batch-mode?) 'pass 'debug) + #:post-error + (lambda (k . args) + (warn "Error while reading request" k args) + (values keep-alive #f #f #f #f)))))) + (else + (values keep-alive #f #f #f)))))) + +(define (keep-alive? response) + #t) + +;; -> (#f | client) +(define (http-write server client response body) + (let ((response (write-response response client))) + (cond + ((not body)) ; pass + ((string? body) + (write-response-body/latin-1 response body)) + ((bytevector? body) + (write-response-body/bytevector response body)) + (else + (error "Expected a string or bytevector for body" body))) + (force-output (response-port response)) + (if (keep-alive? response) + (response-port response) + (begin + (close-port (response-port response)) + #f)))) + +;; -> unspecified values +(define (http-close server) + (shutdown server 2) + (close-port server)) + +(define-server-impl http + http-open + http-read + http-write + http-close)