diff options
author | Andy Wingo <wingo@pobox.com> | 2010-11-12 12:07:24 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-11-12 17:16:36 +0100 |
commit | 79ef79ee348401917e220170454b0d2c502060b9 (patch) | |
tree | caaeb3302b76ba3eece7034cb121d0376721615d /module/web/server.scm | |
parent | d4b6200a0a2f18bdad6d6e9d54c5213748a3b34d (diff) | |
download | guile-79ef79ee348401917e220170454b0d2c502060b9.tar.gz |
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.
Diffstat (limited to 'module/web/server.scm')
-rw-r--r-- | module/web/server.scm | 242 |
1 files changed, 242 insertions, 0 deletions
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 <server-impl> 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 +;;; <server-impl> object. Procedures in this module take a +;;; <server-impl> object, if needed. +;;; +;;; A <server-impl> 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 +;;; <server-impl> 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 +;;; `<request>' 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 `<response>' 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))))) |