1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
|
;;; Web server
;; Copyright (C) 2010, 2011, 2012 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 (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)
#: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 *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 @var{impl} is a server
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
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}."
(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. Returns one value, the
new server object. The implementation's @code{open} procedure is
applied to @var{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 @var{server}, by applying the implementation's
@code{read} procedure to the server. If successful, returns three
values: an object corresponding to the client, a request object, and the
request body. If any exception occurs, returns @code{#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))))
;; 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-alist alist k v)
(let ((pair (assq k alist)))
(acons k v (if pair (delq pair alist) alist))))
(let ((r (build-response #:version (response-version r)
#:code (response-code r)
#:headers
(extend-alist (response-headers r) k v)
#:port (response-port r))))
(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, @var{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 @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.
If @var{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))))
(encode-string 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
(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)))
((zero? blen) response)
(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
@var{handler} with @var{request} and @var{body} as arguments.
The elements of @var{state} are also passed to @var{handler} as
arguments, and may be returned as additional values. The new
@var{state}, collected from the @var{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 @var{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 @var{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
@code{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 @var{server}, call @var{handler} on the request
and body, and write the response to the client. Returns 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.
@var{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 @code{sanitize-response}
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
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
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)))))
|