Merge branch 'stable-2.0'

[bpt/guile.git] / module / web / server.scm

diff --git a/module/web/server.scm b/module/web/server.scm
index b9bdef2..471bb98 100644 (file)
--- a/module/web/server.scm
+++ b/module/web/server.scm
@@ -1,6 +1,6 @@
 ;;; Web server
 
 ;;; Web server
 

-;; Copyright (C)  2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C)  2010, 2011, 2012, 2013 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
 
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public


@@ -74,12 +74,14 @@
 
 (define-module (web server)
   #:use-module (srfi srfi-9)
 
 (define-module (web server)
   #:use-module (srfi srfi-9)

+  #:use-module (srfi srfi-9 gnu)

   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 binary-ports)
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (system repl error-handling)
   #:use-module (ice-9 control)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 binary-ports)
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (system repl error-handling)
   #:use-module (ice-9 control)

+  #:use-module (ice-9 iconv)

   #:export (define-server-impl
             lookup-server-impl
             open-server
   #:export (define-server-impl
             lookup-server-impl
             open-server


@@ -123,14 +125,14 @@
     (make-server-impl 'name open read write close)))
 
 (define (lookup-server-impl impl)
     (make-server-impl 'name open read write close)))
 
 (define (lookup-server-impl impl)

-  "Look up a server implementation.  If @var{impl} is a server
+  "Look up a server implementation.  If IMPL is a server

 implementation already, it is returned directly.  If it is a symbol, the
 implementation already, it is returned directly.  If it is a symbol, the

-binding named @var{impl} in the @code{(web server @var{impl})} module is
+binding named IMPL in the ‘(web server IMPL)’ module is

 looked up.  Otherwise an error is signaled.
 
 Currently a server implementation is a somewhat opaque type, useful only
 for passing to other procedures in this module, like
 looked up.  Otherwise an error is signaled.
 
 Currently a server implementation is a somewhat opaque type, useful only
 for passing to other procedures in this module, like

-@code{read-client}."
+‘read-client’."

   (cond
    ((server-impl? impl) impl)
    ((symbol? impl)
   (cond
    ((server-impl? impl) impl)
    ((symbol? impl)


@@ -143,17 +145,17 @@ for passing to other procedures in this module, like
 
 ;; -> server
 (define (open-server impl open-params)
 
 ;; -> server
 (define (open-server impl open-params)

-  "Open a server for the given implementation.  Returns one value, the
-new server object.  The implementation's @code{open} procedure is
-applied to @var{open-params}, which should be a list."
+  "Open a server for the given implementation.  Return one value, the
+new server object.  The implementation's ‘open’ procedure is
+applied to OPEN-PARAMS, which should be a list."

   (apply (server-impl-open impl) open-params))
 
 ;; -> (client request body | #f #f #f)
 (define (read-client impl server)
   (apply (server-impl-open impl) open-params))
 
 ;; -> (client request body | #f #f #f)
 (define (read-client impl server)

-  "Read a new client from @var{server}, by applying the implementation's
-@code{read} procedure to the server.  If successful, returns three
+  "Read a new client from SERVER, by applying the implementation's
+‘read’ procedure to the server.  If successful, return three

 values: an object corresponding to the client, a request object, and the
 values: an object corresponding to the client, a request object, and the

-request body.  If any exception occurs, returns @code{#f} for all three
+request body.  If any exception occurs, return ‘#f’ for all three

 values."
   (call-with-error-handling
    (lambda ()
 values."
   (call-with-error-handling
    (lambda ()


@@ -162,48 +164,12 @@ values."
    #:on-error (if (batch-mode?) 'backtrace 'debug)
    #:post-error (lambda _ (values #f #f #f))))
 
    #:on-error (if (batch-mode?) 'backtrace 'debug)
    #:post-error (lambda _ (values #f #f #f))))
 

-;; like call-with-output-string, but actually closes the port (doh)
-(define (call-with-output-string* proc)
-  (let ((port (open-output-string)))
-    (proc port)
-    (let ((str (get-output-string port)))
-      (close-port port)
-      str)))
-
-(define (call-with-output-bytevector* proc)
-  (call-with-values
-      (lambda ()
-        (open-bytevector-output-port))
-    (lambda (port get-bytevector)
-      (proc port)
-      (let ((bv (get-bytevector)))
-        (close-port port)
-        bv))))
-
-(define (call-with-encoded-output-string charset proc)
-  (if (string-ci=? charset "utf-8")
-      ;; I don't know why, but this appears to be faster; at least for
-      ;; examples/debug-sxml.scm (1464 reqs/s versus 850 reqs/s).
-      (string->utf8 (call-with-output-string* proc))
-      (call-with-output-bytevector*
-       (lambda (port)
-         (set-port-encoding! port charset)
-         (proc port)))))
-
-(define (encode-string str charset)
-  (if (string-ci=? charset "utf-8")
-      (string->utf8 str)
-      (call-with-encoded-output-string charset
-                                       (lambda (port)
-                                         (display str port)))))
-

 (define (extend-response r k v . additional)
 (define (extend-response r k v . additional)

-  (let ((r (build-response #:version (response-version r)
-                           #:code (response-code r)
-                           #:headers
-                           (assoc-set! (copy-tree (response-headers r))
-                                       k v)
-                           #:port (response-port r))))
+  (define (extend-alist alist k v)
+    (let ((pair (assq k alist)))
+      (acons k v (if pair (delq pair alist) alist))))
+  (let ((r (set-field r (response-headers)
+                      (extend-alist (response-headers r) k v))))

     (if (null? additional)
         r
         (apply extend-response r additional))))
     (if (null? additional)
         r
         (apply extend-response r additional))))


@@ -213,14 +179,14 @@ values."
   "\"Sanitize\" the given response and body, making them appropriate for
 the given request.
 
   "\"Sanitize\" the given response and body, making them appropriate for
 the given request.
 

-As a convenience to web handler authors, @var{response} may be given as
+As a convenience to web handler authors, RESPONSE may be given as

 an alist of headers, in which case it is used to construct a default
 response.  Ensures that the response version corresponds to the request
 an alist of headers, in which case it is used to construct a default
 response.  Ensures that the response version corresponds to the request

-version.  If @var{body} is a string, encodes the string to a bytevector,
-in an encoding appropriate for @var{response}.  Adds a
-@code{content-length} and @code{content-type} header, as necessary.
+version.  If BODY is a string, encodes the string to a bytevector,
+in an encoding appropriate for RESPONSE.  Adds a
+‘content-length’ and ‘content-type’ header, as necessary.

 
 

-If @var{body} is a procedure, it is called with a port as an argument,
+If BODY is a procedure, it is called with a port as an argument,

 and the output collected as a bytevector.  In the future we might try to
 instead use a compressing, chunk-encoded port, and call this procedure
 later, in the write-client procedure.  Authors are advised not to rely
 and the output collected as a bytevector.  In the future we might try to
 instead use a compressing, chunk-encoded port, and call this procedure
 later, in the write-client procedure.  Authors are advised not to rely


@@ -249,7 +215,7 @@ on the procedure being called at any particular time."
            response
            (extend-response response 'content-type
                             `(,@type (charset . ,charset))))
            response
            (extend-response response 'content-type
                             `(,@type (charset . ,charset))))

-       (encode-string body charset))))
+       (string->bytevector body charset))))

    ((procedure? body)
     (let* ((type (response-content-type response
                                         '(text/plain)))
    ((procedure? body)
     (let* ((type (response-content-type response
                                         '(text/plain)))


@@ -262,7 +228,14 @@ on the procedure being called at any particular time."
            (extend-response response 'content-type
                             `(,@type (charset . ,charset))))
        (call-with-encoded-output-string charset body))))
            (extend-response response 'content-type
                             `(,@type (charset . ,charset))))
        (call-with-encoded-output-string charset body))))

-   ((bytevector? body)
+   ((not (bytevector? body))
+    (error "unexpected body type"))
+   ((and (response-must-not-include-body? response)
+         body
+         ;; FIXME make this stricter: even an empty body should be prohibited.
+         (not (zero? (bytevector-length body))))
+    (error "response with this status code must not include body" response))
+   (else

     ;; check length; assert type; add other required fields?
     (values (let ((rlen (response-content-length response))
                   (blen (bytevector-length body)))
     ;; check length; assert type; add other required fields?
     (values (let ((rlen (response-content-length response))
                   (blen (bytevector-length body)))


@@ -270,22 +243,24 @@ on the procedure being called at any particular time."
                (rlen (if (= rlen blen)
                          response
                          (error "bad content-length" rlen blen)))
                (rlen (if (= rlen blen)
                          response
                          (error "bad content-length" rlen blen)))

-               ((zero? blen) response)

                (else (extend-response response 'content-length blen))))
                (else (extend-response response 'content-length blen))))

-            body))
-   (else
-    (error "unexpected body type"))))
+            (if (eq? (request-method request) 'HEAD)
+                ;; Responses to HEAD requests must not include bodies.
+                ;; We could raise an error here, but it seems more
+                ;; appropriate to just do something sensible.
+                #f
+                body)))))

 
 ;; -> response body state
 (define (handle-request handler request body state)
   "Handle a given request, returning the response and body.
 
 The response and response body are produced by calling the given
 
 ;; -> response body state
 (define (handle-request handler request body state)
   "Handle a given request, returning the response and body.
 
 The response and response body are produced by calling the given

-@var{handler} with @var{request} and @var{body} as arguments.
+HANDLER with REQUEST and BODY as arguments.

 
 

-The elements of @var{state} are also passed to @var{handler} as
+The elements of STATE are also passed to HANDLER as

 arguments, and may be returned as additional values.  The new
 arguments, and may be returned as additional values.  The new

-@var{state}, collected from the @var{handler}'s return values, is then
+STATE, collected from the HANDLER's return values, is then

 returned as a list.  The idea is that a server loop receives a handler
 from the user, along with whatever state values the user is interested
 in, allowing the user's handler to explicitly manage its state."
 returned as a list.  The idea is that a server loop receives a handler
 from the user, along with whatever state values the user is interested
 in, allowing the user's handler to explicitly manage its state."


@@ -309,10 +284,10 @@ in, allowing the user's handler to explicitly manage its state."
 
 ;; -> unspecified values
 (define (write-client impl server client response body)
 
 ;; -> unspecified values
 (define (write-client impl server client response body)

-  "Write an HTTP response and body to @var{client}.  If the server and
+  "Write an HTTP response and body to CLIENT.  If the server and

 client support persistent connections, it is the implementation's
 responsibility to keep track of the client thereafter, presumably by
 client support persistent connections, it is the implementation's
 responsibility to keep track of the client thereafter, presumably by

-attaching it to the @var{server} argument somehow."
+attaching it to the SERVER argument somehow."

   (call-with-error-handling
    (lambda ()
      ((server-impl-write impl) server client response body))
   (call-with-error-handling
    (lambda ()
      ((server-impl-write impl) server client response body))


@@ -323,7 +298,7 @@ attaching it to the @var{server} argument somehow."
 ;; -> unspecified values
 (define (close-server impl server)
   "Release resources allocated by a previous invocation of
 ;; -> unspecified values
 (define (close-server impl server)
   "Release resources allocated by a previous invocation of

-@code{open-server}."
+‘open-server’."

   ((server-impl-close impl) server))
 
 (define call-with-sigint
   ((server-impl-close impl) server))
 
 (define call-with-sigint


@@ -354,8 +329,8 @@ attaching it to the @var{server} argument somehow."
   
 ;; -> new-state
 (define (serve-one-client handler impl server state)
   
 ;; -> new-state
 (define (serve-one-client handler impl server state)

-  "Read one request from @var{server}, call @var{handler} on the request
-and body, and write the response to the client.  Returns the new state
+  "Read one request from SERVER, call HANDLER on the request
+and body, and write the response to the client.  Return the new state

 produced by the handler procedure."
   (debug-elapsed 'serve-again)
   (call-with-values
 produced by the handler procedure."
   (debug-elapsed 'serve-again)
   (call-with-values


@@ -378,7 +353,7 @@ produced by the handler procedure."
                      . state)
   "Run Guile's built-in web server.
 
                      . state)
   "Run Guile's built-in web server.
 

-@var{handler} should be a procedure that takes two or more arguments,
+HANDLER should be a procedure that takes two or more arguments,

 the HTTP request and request body, and returns two or more values, the
 response and response body.
 
 the HTTP request and request body, and returns two or more values, the
 response and response body.
 


@@ -391,16 +366,16 @@ For example, here is a simple \"Hello, World!\" server:
  (run-server handler)
 @end example
 
  (run-server handler)
 @end example
 

-The response and body will be run through @code{sanitize-response}
+The response and body will be run through ‘sanitize-response’

 before sending back to the client.
 
 before sending back to the client.
 

-Additional arguments to @var{handler} are taken from
-@var{state}. Additional return values are accumulated into a new
-@var{state}, which will be used for subsequent requests.  In this way a
+Additional arguments to HANDLER are taken from
+STATE.  Additional return values are accumulated into a new
+STATE, which will be used for subsequent requests.  In this way a

 handler can explicitly manage its state.
 
 handler can explicitly manage its state.
 

-The default server implementation is @code{http}, which accepts
-@var{open-params} like @code{(#:port 8081)}, among others.  See \"Web
+The default server implementation is ‘http’, which accepts
+OPEN-PARAMS like ‘(#:port 8081)’, among others.  See \"Web

 Server\" in the manual, for more information."
   (let* ((impl (lookup-server-impl impl))
          (server (open-server impl open-params)))
 Server\" in the manual, for more information."
   (let* ((impl (lookup-server-impl impl))
          (server (open-server impl open-params)))