3 ;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
5 ;; This library is free software; you can redistribute it and/or
6 ;; modify it under the terms of the GNU Lesser General Public
7 ;; License as published by the Free Software Foundation; either
8 ;; version 3 of the License, or (at your option) any later version.
10 ;; This library is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;; Lesser General Public License for more details.
15 ;; You should have received a copy of the GNU Lesser General Public
16 ;; License along with this library; if not, write to the Free Software
17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
22 ;;; (web server) is a generic web server interface, along with a main
23 ;;; loop implementation for web servers controlled by Guile.
25 ;;; The lowest layer is the <server-impl> object, which defines a set of
26 ;;; hooks to open a server, read a request from a client, write a
27 ;;; response to a client, and close a server. These hooks -- open,
28 ;;; read, write, and close, respectively -- are bound together in a
29 ;;; <server-impl> object. Procedures in this module take a
30 ;;; <server-impl> object, if needed.
32 ;;; A <server-impl> may also be looked up by name. If you pass the
33 ;;; `http' symbol to `run-server', Guile looks for a variable named
34 ;;; `http' in the `(web server http)' module, which should be bound to a
35 ;;; <server-impl> object. Such a binding is made by instantiation of
36 ;;; the `define-server-impl' syntax. In this way the run-server loop can
37 ;;; automatically load other backends if available.
39 ;;; The life cycle of a server goes as follows:
41 ;;; * The `open' hook is called, to open the server. `open' takes 0 or
42 ;;; more arguments, depending on the backend, and returns an opaque
43 ;;; server socket object, or signals an error.
45 ;;; * The `read' hook is called, to read a request from a new client.
46 ;;; The `read' hook takes one arguments, the server socket. It
47 ;;; should return three values: an opaque client socket, the
48 ;;; request, and the request body. The request should be a
49 ;;; `<request>' object, from `(web request)'. The body should be a
50 ;;; string or a bytevector, or `#f' if there is no body.
52 ;;; If the read failed, the `read' hook may return #f for the client
53 ;;; socket, request, and body.
55 ;;; * A user-provided handler procedure is called, with the request
56 ;;; and body as its arguments. The handler should return two
57 ;;; values: the response, as a `<response>' record from `(web
58 ;;; response)', and the response body as a string, bytevector, or
59 ;;; `#f' if not present. We also allow the reponse to be simply an
60 ;;; alist of headers, in which case a default response object is
61 ;;; constructed with those headers.
63 ;;; * The `write' hook is called with three arguments: the client
64 ;;; socket, the response, and the body. The `write' hook returns no
67 ;;; * At this point the request handling is complete. For a loop, we
68 ;;; loop back and try to read a new request.
70 ;;; * If the user interrupts the loop, the `close' hook is called on
71 ;;; the server socket.
75 (define-module (web server)
76 #:use-module (srfi srfi-9)
77 #:use-module (rnrs bytevectors)
78 #:use-module (ice-9 binary-ports)
79 #:use-module (web request)
80 #:use-module (web response)
81 #:use-module (system repl error-handling)
82 #:use-module (ice-9 control)
83 #:export (define-server-impl
94 (define *timer* (gettimeofday))
95 (define (print-elapsed who)
96 (let ((t (gettimeofday)))
97 (pk who (+ (* (- (car t) (car *timer*)) 1000000)
98 (- (cdr t) (cdr *timer*))))
102 (define *time-debug?* #f))
104 (define-syntax debug-elapsed
109 #'(print-elapsed who)
112 (define-record-type server-impl
113 (make-server-impl name open read write close)
115 (name server-impl-name)
116 (open server-impl-open)
117 (read server-impl-read)
118 (write server-impl-write)
119 (close server-impl-close))
121 (define-syntax-rule (define-server-impl name open read write close)
123 (make-server-impl 'name open read write close)))
125 (define (lookup-server-impl impl)
126 "Look up a server implementation. If @var{impl} is a server
127 implementation already, it is returned directly. If it is a symbol, the
128 binding named @var{impl} in the @code{(web server @var{impl})} module is
129 looked up. Otherwise an error is signaled.
131 Currently a server implementation is a somewhat opaque type, useful only
132 for passing to other procedures in this module, like
135 ((server-impl? impl) impl)
137 (let ((impl (module-ref (resolve-module `(web server ,impl)) impl)))
138 (if (server-impl? impl)
140 (error "expected a server impl in module" `(web server ,impl)))))
142 (error "expected a server-impl or a symbol" impl))))
145 (define (open-server impl open-params)
146 "Open a server for the given implementation. Returns one value, the
147 new server object. The implementation's @code{open} procedure is
148 applied to @var{open-params}, which should be a list."
149 (apply (server-impl-open impl) open-params))
151 ;; -> (client request body | #f #f #f)
152 (define (read-client impl server)
153 "Read a new client from @var{server}, by applying the implementation's
154 @code{read} procedure to the server. If successful, returns three
155 values: an object corresponding to the client, a request object, and the
156 request body. If any exception occurs, returns @code{#f} for all three
158 (call-with-error-handling
160 ((server-impl-read impl) server))
161 #:pass-keys '(quit interrupt)
162 #:on-error (if (batch-mode?) 'backtrace 'debug)
163 #:post-error (lambda _ (values #f #f #f))))
165 ;; like call-with-output-string, but actually closes the port (doh)
166 (define (call-with-output-string* proc)
167 (let ((port (open-output-string)))
169 (let ((str (get-output-string port)))
173 (define (call-with-output-bytevector* proc)
176 (open-bytevector-output-port))
177 (lambda (port get-bytevector)
179 (let ((bv (get-bytevector)))
183 (define (call-with-encoded-output-string charset proc)
184 (if (string-ci=? charset "utf-8")
185 ;; I don't know why, but this appears to be faster; at least for
186 ;; examples/debug-sxml.scm (1464 reqs/s versus 850 reqs/s).
187 (string->utf8 (call-with-output-string* proc))
188 (call-with-output-bytevector*
190 (set-port-encoding! port charset)
193 (define (encode-string str charset)
194 (if (string-ci=? charset "utf-8")
196 (call-with-encoded-output-string charset
198 (display str port)))))
200 (define (extend-response r k v . additional)
201 (define (extend-alist alist k v)
202 (let ((pair (assq k alist)))
203 (acons k v (if pair (delq pair alist) alist))))
204 (let ((r (build-response #:version (response-version r)
205 #:code (response-code r)
207 (extend-alist (response-headers r) k v)
208 #:port (response-port r))))
209 (if (null? additional)
211 (apply extend-response r additional))))
214 (define (sanitize-response request response body)
215 "\"Sanitize\" the given response and body, making them appropriate for
218 As a convenience to web handler authors, @var{response} may be given as
219 an alist of headers, in which case it is used to construct a default
220 response. Ensures that the response version corresponds to the request
221 version. If @var{body} is a string, encodes the string to a bytevector,
222 in an encoding appropriate for @var{response}. Adds a
223 @code{content-length} and @code{content-type} header, as necessary.
225 If @var{body} is a procedure, it is called with a port as an argument,
226 and the output collected as a bytevector. In the future we might try to
227 instead use a compressing, chunk-encoded port, and call this procedure
228 later, in the write-client procedure. Authors are advised not to rely
229 on the procedure being called at any particular time."
232 (sanitize-response request
233 (build-response #:version (request-version request)
236 ((not (equal? (request-version request) (response-version response)))
237 (sanitize-response request
238 (adapt-response-version response
239 (request-version request))
242 (values response #vu8()))
244 (let* ((type (response-content-type response
246 (declared-charset (assq-ref (cdr type) 'charset))
247 (charset (or declared-charset "utf-8")))
252 (extend-response response 'content-type
253 `(,@type (charset . ,charset))))
254 (encode-string body charset))))
256 (let* ((type (response-content-type response
258 (declared-charset (assq-ref (cdr type) 'charset))
259 (charset (or declared-charset "utf-8")))
264 (extend-response response 'content-type
265 `(,@type (charset . ,charset))))
266 (call-with-encoded-output-string charset body))))
267 ((not (bytevector? body))
268 (error "unexpected body type"))
269 ((and (response-must-not-include-body? response)
271 (not (zero? (bytevector-length body))))
272 (error "response with this status code must not include body" response))
274 ;; check length; assert type; add other required fields?
275 (values (let ((rlen (response-content-length response))
276 (blen (bytevector-length body)))
278 (rlen (if (= rlen blen)
280 (error "bad content-length" rlen blen)))
281 ((zero? blen) response)
282 (else (extend-response response 'content-length blen))))
283 (if (eq? (request-method request) 'HEAD)
284 ;; Responses to HEAD requests must not include bodies.
285 ;; We could raise an error here, but it seems more
286 ;; appropriate to just do something sensible.
290 ;; -> response body state
291 (define (handle-request handler request body state)
292 "Handle a given request, returning the response and body.
294 The response and response body are produced by calling the given
295 @var{handler} with @var{request} and @var{body} as arguments.
297 The elements of @var{state} are also passed to @var{handler} as
298 arguments, and may be returned as additional values. The new
299 @var{state}, collected from the @var{handler}'s return values, is then
300 returned as a list. The idea is that a server loop receives a handler
301 from the user, along with whatever state values the user is interested
302 in, allowing the user's handler to explicitly manage its state."
303 (call-with-error-handling
305 (call-with-values (lambda ()
306 (with-stack-and-prompt
308 (apply handler request body state))))
309 (lambda (response body . state)
310 (call-with-values (lambda ()
311 (debug-elapsed 'handler)
312 (sanitize-response request response body))
313 (lambda (response body)
314 (debug-elapsed 'sanitize)
315 (values response body state))))))
316 #:pass-keys '(quit interrupt)
317 #:on-error (if (batch-mode?) 'backtrace 'debug)
318 #:post-error (lambda _
319 (values (build-response #:code 500) #f state))))
321 ;; -> unspecified values
322 (define (write-client impl server client response body)
323 "Write an HTTP response and body to @var{client}. If the server and
324 client support persistent connections, it is the implementation's
325 responsibility to keep track of the client thereafter, presumably by
326 attaching it to the @var{server} argument somehow."
327 (call-with-error-handling
329 ((server-impl-write impl) server client response body))
330 #:pass-keys '(quit interrupt)
331 #:on-error (if (batch-mode?) 'backtrace 'debug)
332 #:post-error (lambda _ (values))))
334 ;; -> unspecified values
335 (define (close-server impl server)
336 "Release resources allocated by a previous invocation of
338 ((server-impl-close impl) server))
340 (define call-with-sigint
341 (if (not (provided? 'posix))
342 (lambda (thunk handler-thunk) (thunk))
343 (lambda (thunk handler-thunk)
350 (sigaction SIGINT (lambda (sig) (throw 'interrupt)))))
354 ;; restore Scheme handler, SIG_IGN or SIG_DFL.
355 (sigaction SIGINT (car handler) (cdr handler))
356 ;; restore original C handler.
357 (sigaction SIGINT #f)))))
358 (lambda (k . _) (handler-thunk)))))))
360 (define (with-stack-and-prompt thunk)
361 (call-with-prompt (default-prompt-tag)
362 (lambda () (start-stack #t (thunk)))
364 (with-stack-and-prompt (lambda () (proc k))))))
367 (define (serve-one-client handler impl server state)
368 "Read one request from @var{server}, call @var{handler} on the request
369 and body, and write the response to the client. Returns the new state
370 produced by the handler procedure."
371 (debug-elapsed 'serve-again)
374 (read-client impl server))
375 (lambda (client request body)
376 (debug-elapsed 'read-client)
380 (handle-request handler request body state))
381 (lambda (response body state)
382 (debug-elapsed 'handle-request)
383 (write-client impl server client response body)
384 (debug-elapsed 'write-client)
388 (define* (run-server handler #:optional (impl 'http) (open-params '())
390 "Run Guile's built-in web server.
392 @var{handler} should be a procedure that takes two or more arguments,
393 the HTTP request and request body, and returns two or more values, the
394 response and response body.
396 For example, here is a simple \"Hello, World!\" server:
399 (define (handler request body)
400 (values '((content-type . (text/plain)))
405 The response and body will be run through @code{sanitize-response}
406 before sending back to the client.
408 Additional arguments to @var{handler} are taken from
409 @var{state}. Additional return values are accumulated into a new
410 @var{state}, which will be used for subsequent requests. In this way a
411 handler can explicitly manage its state.
413 The default server implementation is @code{http}, which accepts
414 @var{open-params} like @code{(#:port 8081)}, among others. See \"Web
415 Server\" in the manual, for more information."
416 (let* ((impl (lookup-server-impl impl))
417 (server (open-server impl open-params)))
420 (let lp ((state state))
421 (lp (serve-one-client handler impl server state))))
423 (close-server impl server)