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

@@ -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
 

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)))))

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)