Commit | Line | Data |
---|---|---|
79ef79ee AW |
1 | ;;; Web server |
2 | ||
2263ccb5 | 3 | ;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc. |
79ef79ee AW |
4 | |
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. | |
9 | ;; | |
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. | |
14 | ;; | |
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 | |
18 | ;; 02110-1301 USA | |
19 | ||
20 | ;;; Commentary: | |
21 | ;;; | |
22 | ;;; (web server) is a generic web server interface, along with a main | |
23 | ;;; loop implementation for web servers controlled by Guile. | |
24 | ;;; | |
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. | |
31 | ;;; | |
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. | |
38 | ;;; | |
39 | ;;; The life cycle of a server goes as follows: | |
40 | ;;; | |
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. | |
44 | ;;; | |
45 | ;;; * The `read' hook is called, to read a request from a new client. | |
462a1a04 AW |
46 | ;;; The `read' hook takes one arguments, the server socket. It |
47 | ;;; should return three values: an opaque client socket, the | |
79ef79ee AW |
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. | |
51 | ;;; | |
79ef79ee AW |
52 | ;;; If the read failed, the `read' hook may return #f for the client |
53 | ;;; socket, request, and body. | |
54 | ;;; | |
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. | |
62 | ;;; | |
63 | ;;; * The `write' hook is called with three arguments: the client | |
462a1a04 AW |
64 | ;;; socket, the response, and the body. The `write' hook returns no |
65 | ;;; values. | |
79ef79ee AW |
66 | ;;; |
67 | ;;; * At this point the request handling is complete. For a loop, we | |
462a1a04 | 68 | ;;; loop back and try to read a new request. |
79ef79ee AW |
69 | ;;; |
70 | ;;; * If the user interrupts the loop, the `close' hook is called on | |
71 | ;;; the server socket. | |
72 | ;;; | |
73 | ;;; Code: | |
74 | ||
75 | (define-module (web server) | |
76 | #:use-module (srfi srfi-9) | |
77 | #:use-module (rnrs bytevectors) | |
6854c324 | 78 | #:use-module (ice-9 binary-ports) |
79ef79ee AW |
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 | |
84 | lookup-server-impl | |
85 | open-server | |
86 | read-client | |
87 | handle-request | |
88 | sanitize-response | |
89 | write-client | |
90 | close-server | |
91 | serve-one-client | |
92 | run-server)) | |
93 | ||
8bf6cfea AW |
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*)))) | |
99 | (set! *timer* t))) | |
100 | ||
101 | (eval-when (expand) | |
102 | (define *time-debug?* #f)) | |
103 | ||
104 | (define-syntax debug-elapsed | |
105 | (lambda (x) | |
106 | (syntax-case x () | |
107 | ((_ who) | |
108 | (if *time-debug?* | |
109 | #'(print-elapsed who) | |
110 | #'*unspecified*))))) | |
111 | ||
79ef79ee AW |
112 | (define-record-type server-impl |
113 | (make-server-impl name open read write close) | |
114 | server-impl? | |
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)) | |
120 | ||
0c65f52c AW |
121 | (define-syntax-rule (define-server-impl name open read write close) |
122 | (define name | |
123 | (make-server-impl 'name open read write close))) | |
79ef79ee AW |
124 | |
125 | (define (lookup-server-impl impl) | |
43d6659a AW |
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. | |
130 | ||
131 | Currently a server implementation is a somewhat opaque type, useful only | |
132 | for passing to other procedures in this module, like | |
133 | @code{read-client}." | |
79ef79ee AW |
134 | (cond |
135 | ((server-impl? impl) impl) | |
136 | ((symbol? impl) | |
137 | (let ((impl (module-ref (resolve-module `(web server ,impl)) impl))) | |
138 | (if (server-impl? impl) | |
139 | impl | |
140 | (error "expected a server impl in module" `(web server ,impl))))) | |
141 | (else | |
142 | (error "expected a server-impl or a symbol" impl)))) | |
143 | ||
144 | ;; -> server | |
145 | (define (open-server impl open-params) | |
43d6659a AW |
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." | |
79ef79ee AW |
149 | (apply (server-impl-open impl) open-params)) |
150 | ||
462a1a04 AW |
151 | ;; -> (client request body | #f #f #f) |
152 | (define (read-client impl server) | |
43d6659a AW |
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 | |
157 | values." | |
79ef79ee AW |
158 | (call-with-error-handling |
159 | (lambda () | |
462a1a04 | 160 | ((server-impl-read impl) server)) |
79ef79ee | 161 | #:pass-keys '(quit interrupt) |
2263ccb5 AW |
162 | #:on-error (if (batch-mode?) 'backtrace 'debug) |
163 | #:post-error (lambda _ (values #f #f #f)))) | |
79ef79ee | 164 | |
a964aa62 AW |
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))) | |
168 | (proc port) | |
169 | (let ((str (get-output-string port))) | |
170 | (close-port port) | |
171 | str))) | |
172 | ||
173 | (define (call-with-output-bytevector* proc) | |
174 | (call-with-values | |
175 | (lambda () | |
176 | (open-bytevector-output-port)) | |
177 | (lambda (port get-bytevector) | |
178 | (proc port) | |
179 | (let ((bv (get-bytevector))) | |
180 | (close-port port) | |
181 | bv)))) | |
182 | ||
af0da6eb | 183 | (define (call-with-encoded-output-string charset proc) |
998191fd | 184 | (if (string-ci=? charset "utf-8") |
af0da6eb | 185 | ;; I don't know why, but this appears to be faster; at least for |
998191fd | 186 | ;; examples/debug-sxml.scm (1464 reqs/s versus 850 reqs/s). |
a964aa62 AW |
187 | (string->utf8 (call-with-output-string* proc)) |
188 | (call-with-output-bytevector* | |
189 | (lambda (port) | |
190 | (set-port-encoding! port charset) | |
191 | (proc port))))) | |
af0da6eb | 192 | |
d9f00c3d | 193 | (define (encode-string str charset) |
af0da6eb AW |
194 | (if (string-ci=? charset "utf-8") |
195 | (string->utf8 str) | |
196 | (call-with-encoded-output-string charset | |
197 | (lambda (port) | |
198 | (display str port))))) | |
d9f00c3d | 199 | |
f944ee8f AW |
200 | (define (extend-response r k v . additional) |
201 | (let ((r (build-response #:version (response-version r) | |
202 | #:code (response-code r) | |
203 | #:headers | |
204 | (assoc-set! (copy-tree (response-headers r)) | |
205 | k v) | |
206 | #:port (response-port r)))) | |
207 | (if (null? additional) | |
208 | r | |
209 | (apply extend-response r additional)))) | |
210 | ||
79ef79ee AW |
211 | ;; -> response body |
212 | (define (sanitize-response request response body) | |
43d6659a AW |
213 | "\"Sanitize\" the given response and body, making them appropriate for |
214 | the given request. | |
215 | ||
216 | As a convenience to web handler authors, @var{response} may be given as | |
217 | an alist of headers, in which case it is used to construct a default | |
218 | response. Ensures that the response version corresponds to the request | |
219 | version. If @var{body} is a string, encodes the string to a bytevector, | |
220 | in an encoding appropriate for @var{response}. Adds a | |
221 | @code{content-length} and @code{content-type} header, as necessary. | |
222 | ||
223 | If @var{body} is a procedure, it is called with a port as an argument, | |
224 | and the output collected as a bytevector. In the future we might try to | |
225 | instead use a compressing, chunk-encoded port, and call this procedure | |
226 | later, in the write-client procedure. Authors are advised not to rely | |
227 | on the procedure being called at any particular time." | |
d9f00c3d AW |
228 | (cond |
229 | ((list? response) | |
c6371902 AW |
230 | (sanitize-response request |
231 | (build-response #:version (request-version request) | |
232 | #:headers response) | |
233 | body)) | |
234 | ((not (equal? (request-version request) (response-version response))) | |
235 | (sanitize-response request | |
236 | (adapt-response-version response | |
237 | (request-version request)) | |
238 | body)) | |
a4342ba8 AW |
239 | ((not body) |
240 | (values response #vu8())) | |
d9f00c3d AW |
241 | ((string? body) |
242 | (let* ((type (response-content-type response | |
0acc595b AW |
243 | '(text/plain))) |
244 | (declared-charset (assq-ref (cdr type) 'charset)) | |
af0da6eb | 245 | (charset (or declared-charset "utf-8"))) |
d9f00c3d AW |
246 | (sanitize-response |
247 | request | |
248 | (if declared-charset | |
249 | response | |
250 | (extend-response response 'content-type | |
0acc595b | 251 | `(,@type (charset . ,charset)))) |
d9f00c3d AW |
252 | (encode-string body charset)))) |
253 | ((procedure? body) | |
af0da6eb | 254 | (let* ((type (response-content-type response |
0acc595b AW |
255 | '(text/plain))) |
256 | (declared-charset (assq-ref (cdr type) 'charset)) | |
af0da6eb AW |
257 | (charset (or declared-charset "utf-8"))) |
258 | (sanitize-response | |
259 | request | |
260 | (if declared-charset | |
261 | response | |
262 | (extend-response response 'content-type | |
0acc595b | 263 | `(,@type (charset . ,charset)))) |
af0da6eb | 264 | (call-with-encoded-output-string charset body)))) |
164a78b3 AW |
265 | ((not (bytevector? body)) |
266 | (error "unexpected body type")) | |
267 | ((response-must-not-include-body? response) | |
268 | (error "response with this status code must not include body" response)) | |
269 | (else | |
d9f00c3d | 270 | ;; check length; assert type; add other required fields? |
a4342ba8 AW |
271 | (values (let ((rlen (response-content-length response)) |
272 | (blen (bytevector-length body))) | |
273 | (cond | |
612aa5be AW |
274 | (rlen (if (= rlen blen) |
275 | response | |
276 | (error "bad content-length" rlen blen))) | |
a4342ba8 AW |
277 | ((zero? blen) response) |
278 | (else (extend-response response 'content-length blen)))) | |
164a78b3 AW |
279 | (if (eq? (request-method request) 'HEAD) |
280 | ;; Responses to HEAD requests must not include bodies. | |
281 | ;; We could raise an error here, but it seems more | |
282 | ;; appropriate to just do something sensible. | |
283 | #f | |
284 | body))))) | |
79ef79ee | 285 | |
c6371902 AW |
286 | ;; -> response body state |
287 | (define (handle-request handler request body state) | |
43d6659a AW |
288 | "Handle a given request, returning the response and body. |
289 | ||
290 | The response and response body are produced by calling the given | |
291 | @var{handler} with @var{request} and @var{body} as arguments. | |
292 | ||
293 | The elements of @var{state} are also passed to @var{handler} as | |
294 | arguments, and may be returned as additional values. The new | |
295 | @var{state}, collected from the @var{handler}'s return values, is then | |
296 | returned as a list. The idea is that a server loop receives a handler | |
297 | from the user, along with whatever state values the user is interested | |
298 | in, allowing the user's handler to explicitly manage its state." | |
c6371902 AW |
299 | (call-with-error-handling |
300 | (lambda () | |
301 | (call-with-values (lambda () | |
302 | (with-stack-and-prompt | |
303 | (lambda () | |
304 | (apply handler request body state)))) | |
305 | (lambda (response body . state) | |
306 | (call-with-values (lambda () | |
8bf6cfea | 307 | (debug-elapsed 'handler) |
c6371902 AW |
308 | (sanitize-response request response body)) |
309 | (lambda (response body) | |
8bf6cfea | 310 | (debug-elapsed 'sanitize) |
c6371902 AW |
311 | (values response body state)))))) |
312 | #:pass-keys '(quit interrupt) | |
2263ccb5 AW |
313 | #:on-error (if (batch-mode?) 'backtrace 'debug) |
314 | #:post-error (lambda _ | |
315 | (values (build-response #:code 500) #f state)))) | |
c6371902 | 316 | |
462a1a04 | 317 | ;; -> unspecified values |
79ef79ee | 318 | (define (write-client impl server client response body) |
43d6659a AW |
319 | "Write an HTTP response and body to @var{client}. If the server and |
320 | client support persistent connections, it is the implementation's | |
321 | responsibility to keep track of the client thereafter, presumably by | |
322 | attaching it to the @var{server} argument somehow." | |
79ef79ee AW |
323 | (call-with-error-handling |
324 | (lambda () | |
325 | ((server-impl-write impl) server client response body)) | |
326 | #:pass-keys '(quit interrupt) | |
2263ccb5 AW |
327 | #:on-error (if (batch-mode?) 'backtrace 'debug) |
328 | #:post-error (lambda _ (values)))) | |
79ef79ee AW |
329 | |
330 | ;; -> unspecified values | |
331 | (define (close-server impl server) | |
43d6659a AW |
332 | "Release resources allocated by a previous invocation of |
333 | @code{open-server}." | |
79ef79ee AW |
334 | ((server-impl-close impl) server)) |
335 | ||
336 | (define call-with-sigint | |
337 | (if (not (provided? 'posix)) | |
338 | (lambda (thunk handler-thunk) (thunk)) | |
339 | (lambda (thunk handler-thunk) | |
340 | (let ((handler #f)) | |
341 | (catch 'interrupt | |
342 | (lambda () | |
343 | (dynamic-wind | |
344 | (lambda () | |
345 | (set! handler | |
346 | (sigaction SIGINT (lambda (sig) (throw 'interrupt))))) | |
347 | thunk | |
348 | (lambda () | |
349 | (if handler | |
350 | ;; restore Scheme handler, SIG_IGN or SIG_DFL. | |
351 | (sigaction SIGINT (car handler) (cdr handler)) | |
352 | ;; restore original C handler. | |
353 | (sigaction SIGINT #f))))) | |
354 | (lambda (k . _) (handler-thunk))))))) | |
355 | ||
356 | (define (with-stack-and-prompt thunk) | |
357 | (call-with-prompt (default-prompt-tag) | |
358 | (lambda () (start-stack #t (thunk))) | |
359 | (lambda (k proc) | |
360 | (with-stack-and-prompt (lambda () (proc k)))))) | |
361 | ||
462a1a04 AW |
362 | ;; -> new-state |
363 | (define (serve-one-client handler impl server state) | |
43d6659a AW |
364 | "Read one request from @var{server}, call @var{handler} on the request |
365 | and body, and write the response to the client. Returns the new state | |
366 | produced by the handler procedure." | |
8bf6cfea | 367 | (debug-elapsed 'serve-again) |
79ef79ee AW |
368 | (call-with-values |
369 | (lambda () | |
462a1a04 AW |
370 | (read-client impl server)) |
371 | (lambda (client request body) | |
8bf6cfea | 372 | (debug-elapsed 'read-client) |
79ef79ee AW |
373 | (if client |
374 | (call-with-values | |
375 | (lambda () | |
c6371902 AW |
376 | (handle-request handler request body state)) |
377 | (lambda (response body state) | |
8bf6cfea | 378 | (debug-elapsed 'handle-request) |
462a1a04 AW |
379 | (write-client impl server client response body) |
380 | (debug-elapsed 'write-client) | |
381 | state)) | |
382 | state)))) | |
79ef79ee AW |
383 | |
384 | (define* (run-server handler #:optional (impl 'http) (open-params '()) | |
385 | . state) | |
43d6659a AW |
386 | "Run Guile's built-in web server. |
387 | ||
388 | @var{handler} should be a procedure that takes two or more arguments, | |
389 | the HTTP request and request body, and returns two or more values, the | |
390 | response and response body. | |
391 | ||
392 | For example, here is a simple \"Hello, World!\" server: | |
393 | ||
394 | @example | |
395 | (define (handler request body) | |
0acc595b | 396 | (values '((content-type . (text/plain))) |
43d6659a AW |
397 | \"Hello, World!\")) |
398 | (run-server handler) | |
399 | @end example | |
400 | ||
401 | The response and body will be run through @code{sanitize-response} | |
402 | before sending back to the client. | |
403 | ||
404 | Additional arguments to @var{handler} are taken from | |
405 | @var{state}. Additional return values are accumulated into a new | |
406 | @var{state}, which will be used for subsequent requests. In this way a | |
407 | handler can explicitly manage its state. | |
408 | ||
409 | The default server implementation is @code{http}, which accepts | |
410 | @var{open-params} like @code{(#:port 8081)}, among others. See \"Web | |
411 | Server\" in the manual, for more information." | |
79ef79ee AW |
412 | (let* ((impl (lookup-server-impl impl)) |
413 | (server (open-server impl open-params))) | |
414 | (call-with-sigint | |
415 | (lambda () | |
462a1a04 AW |
416 | (let lp ((state state)) |
417 | (lp (serve-one-client handler impl server state)))) | |
79ef79ee AW |
418 | (lambda () |
419 | (close-server impl server) | |
420 | (values))))) |