summaryrefslogtreecommitdiff
path: root/module/web/server.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/web/server.scm')
-rw-r--r--module/web/server.scm397
1 files changed, 397 insertions, 0 deletions
diff --git a/module/web/server.scm b/module/web/server.scm
new file mode 100644
index 000000000..80028fd7e
--- /dev/null
+++ b/module/web/server.scm
@@ -0,0 +1,397 @@
+;;; Web server
+
+;; Copyright (C) 2010, 2011, 2012, 2013, 2015 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 one arguments, the server socket. It
+;;; should return three values: 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.
+;;;
+;;; 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 returns no
+;;; values.
+;;;
+;;; * At this point the request handling is complete. For a loop, we
+;;; loop back 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 (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 (ice-9 iconv)
+ #:export (define-server-impl
+ lookup-server-impl
+
+ make-server-impl
+ server-impl?
+ server-impl-name
+ server-impl-open
+ server-impl-read
+ server-impl-write
+ server-impl-close
+
+ open-server
+ read-client
+ handle-request
+ sanitize-response
+ write-client
+ close-server
+ serve-one-client
+ run-server))
+
+(define *timer* (gettimeofday))
+(define (print-elapsed who)
+ (let ((t (gettimeofday)))
+ (pk who (+ (* (- (car t) (car *timer*)) 1000000)
+ (- (cdr t) (cdr *timer*))))
+ (set! *timer* t)))
+
+(eval-when (expand)
+ (define *time-debug?* #f))
+
+(define-syntax debug-elapsed
+ (lambda (x)
+ (syntax-case x ()
+ ((_ who)
+ (if *time-debug?*
+ #'(print-elapsed who)
+ #'*unspecified*)))))
+
+(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-rule (define-server-impl name open read write close)
+ (define name
+ (make-server-impl 'name open read write close)))
+
+(define (lookup-server-impl impl)
+ "Look up a server implementation. If IMPL is a server
+implementation already, it is returned directly. If it is a symbol, the
+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
+‘read-client’."
+ (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)
+ "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)
+ "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
+request body. If any exception occurs, return ‘#f’ for all three
+values."
+ (call-with-error-handling
+ (lambda ()
+ ((server-impl-read impl) server))
+ #:pass-keys '(quit interrupt)
+ #:on-error (if (batch-mode?) 'backtrace 'debug)
+ #:post-error (lambda _ (values #f #f #f))))
+
+(define (extend-response r k v . additional)
+ (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))))
+
+;; -> response body
+(define (sanitize-response request response body)
+ "\"Sanitize\" the given response and body, making them appropriate for
+the given request.
+
+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
+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 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
+on the procedure being called at any particular time."
+ (cond
+ ((list? response)
+ (sanitize-response request
+ (build-response #:version (request-version request)
+ #:headers response)
+ body))
+ ((not (equal? (request-version request) (response-version response)))
+ (sanitize-response request
+ (adapt-response-version response
+ (request-version request))
+ body))
+ ((not body)
+ (values response #vu8()))
+ ((string? body)
+ (let* ((type (response-content-type response
+ '(text/plain)))
+ (declared-charset (assq-ref (cdr type) 'charset))
+ (charset (or declared-charset "utf-8")))
+ (sanitize-response
+ request
+ (if declared-charset
+ response
+ (extend-response response 'content-type
+ `(,@type (charset . ,charset))))
+ (string->bytevector body charset))))
+ ((procedure? body)
+ (let* ((type (response-content-type response
+ '(text/plain)))
+ (declared-charset (assq-ref (cdr type) 'charset))
+ (charset (or declared-charset "utf-8")))
+ (sanitize-response
+ request
+ (if declared-charset
+ response
+ (extend-response response 'content-type
+ `(,@type (charset . ,charset))))
+ (call-with-encoded-output-string charset 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)))
+ (cond
+ (rlen (if (= rlen blen)
+ response
+ (error "bad content-length" rlen blen)))
+ (else (extend-response response 'content-length blen))))
+ (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
+HANDLER with REQUEST and BODY as arguments.
+
+The elements of STATE are also passed to HANDLER as
+arguments, and may be returned as additional values. The new
+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."
+ (call-with-error-handling
+ (lambda ()
+ (call-with-values (lambda ()
+ (with-stack-and-prompt
+ (lambda ()
+ (apply handler request body state))))
+ (lambda (response body . state)
+ (call-with-values (lambda ()
+ (debug-elapsed 'handler)
+ (sanitize-response request response body))
+ (lambda (response body)
+ (debug-elapsed 'sanitize)
+ (values response body state))))))
+ #:pass-keys '(quit interrupt)
+ #:on-error (if (batch-mode?) 'backtrace 'debug)
+ #:post-error (lambda _
+ (values (build-response #:code 500) #f state))))
+
+;; -> unspecified values
+(define (write-client impl server client response body)
+ "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
+attaching it to the SERVER argument somehow."
+ (call-with-error-handling
+ (lambda ()
+ ((server-impl-write impl) server client response body))
+ #:pass-keys '(quit interrupt)
+ #:on-error (if (batch-mode?) 'backtrace 'debug)
+ #:post-error (lambda _ (values))))
+
+;; -> unspecified values
+(define (close-server impl server)
+ "Release resources allocated by a previous invocation of
+‘open-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))))))
+
+;; -> new-state
+(define (serve-one-client handler impl server 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
+ (lambda ()
+ (read-client impl server))
+ (lambda (client request body)
+ (debug-elapsed 'read-client)
+ (if client
+ (call-with-values
+ (lambda ()
+ (handle-request handler request body state))
+ (lambda (response body state)
+ (debug-elapsed 'handle-request)
+ (write-client impl server client response body)
+ (debug-elapsed 'write-client)
+ state))
+ state))))
+
+(define* (run-server handler #:optional (impl 'http) (open-params '())
+ . state)
+ "Run Guile's built-in web server.
+
+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.
+
+For example, here is a simple \"Hello, World!\" server:
+
+@example
+ (define (handler request body)
+ (values '((content-type . (text/plain)))
+ \"Hello, World!\"))
+ (run-server handler)
+@end example
+
+The response and body will be run through ‘sanitize-response’
+before sending back to the client.
+
+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.
+
+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)))
+ (call-with-sigint
+ (lambda ()
+ (let lp ((state state))
+ (lp (serve-one-client handler impl server state))))
+ (lambda ()
+ (close-server impl server)
+ (values)))))