Commit | Line | Data |
---|---|---|
79ef79ee AW |
1 | ;;; Web server |
2 | ||
3 | ;; Copyright (C) 2010 Free Software Foundation, Inc. | |
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. | |
46 | ;;; The `read' hook takes two arguments: the server socket, and a | |
47 | ;;; list of keep-alive clients. It should return four values: the | |
48 | ;;; new list of keep-alive clients, an opaque client socket, the | |
49 | ;;; request, and the request body. The request should be a | |
50 | ;;; `<request>' object, from `(web request)'. The body should be a | |
51 | ;;; string or a bytevector, or `#f' if there is no body. | |
52 | ;;; | |
53 | ;;; The keep-alive list is used when selecting a new request. You | |
54 | ;;; can either serve an old client or serve a new client; and some | |
55 | ;;; old clients might close their connections while you are waiting. | |
56 | ;;; The `read' hook returns a new keep-alive set to account for old | |
57 | ;;; clients going away, and for read errors on old clients. | |
58 | ;;; | |
59 | ;;; If the read failed, the `read' hook may return #f for the client | |
60 | ;;; socket, request, and body. | |
61 | ;;; | |
62 | ;;; * A user-provided handler procedure is called, with the request | |
63 | ;;; and body as its arguments. The handler should return two | |
64 | ;;; values: the response, as a `<response>' record from `(web | |
65 | ;;; response)', and the response body as a string, bytevector, or | |
66 | ;;; `#f' if not present. We also allow the reponse to be simply an | |
67 | ;;; alist of headers, in which case a default response object is | |
68 | ;;; constructed with those headers. | |
69 | ;;; | |
70 | ;;; * The `write' hook is called with three arguments: the client | |
71 | ;;; socket, the response, and the body. The `write' hook may return | |
72 | ;;; #f to indicate that the connection was closed. If `write' | |
73 | ;;; returns a true value, it will be consed onto the keep-alive | |
74 | ;;; list. | |
75 | ;;; | |
76 | ;;; * At this point the request handling is complete. For a loop, we | |
77 | ;;; loop back with the new keep-alive list, and try to read a new | |
78 | ;;; request. | |
79 | ;;; | |
80 | ;;; * If the user interrupts the loop, the `close' hook is called on | |
81 | ;;; the server socket. | |
82 | ;;; | |
83 | ;;; Code: | |
84 | ||
85 | (define-module (web server) | |
86 | #:use-module (srfi srfi-9) | |
87 | #:use-module (rnrs bytevectors) | |
af0da6eb | 88 | #:use-module (rnrs io ports) |
79ef79ee AW |
89 | #:use-module (web request) |
90 | #:use-module (web response) | |
91 | #:use-module (system repl error-handling) | |
92 | #:use-module (ice-9 control) | |
93 | #:export (define-server-impl | |
94 | lookup-server-impl | |
95 | open-server | |
96 | read-client | |
97 | handle-request | |
98 | sanitize-response | |
99 | write-client | |
100 | close-server | |
101 | serve-one-client | |
102 | run-server)) | |
103 | ||
8bf6cfea AW |
104 | (define *timer* (gettimeofday)) |
105 | (define (print-elapsed who) | |
106 | (let ((t (gettimeofday))) | |
107 | (pk who (+ (* (- (car t) (car *timer*)) 1000000) | |
108 | (- (cdr t) (cdr *timer*)))) | |
109 | (set! *timer* t))) | |
110 | ||
111 | (eval-when (expand) | |
112 | (define *time-debug?* #f)) | |
113 | ||
114 | (define-syntax debug-elapsed | |
115 | (lambda (x) | |
116 | (syntax-case x () | |
117 | ((_ who) | |
118 | (if *time-debug?* | |
119 | #'(print-elapsed who) | |
120 | #'*unspecified*))))) | |
121 | ||
79ef79ee AW |
122 | (define-record-type server-impl |
123 | (make-server-impl name open read write close) | |
124 | server-impl? | |
125 | (name server-impl-name) | |
126 | (open server-impl-open) | |
127 | (read server-impl-read) | |
128 | (write server-impl-write) | |
129 | (close server-impl-close)) | |
130 | ||
131 | (define-syntax define-server-impl | |
132 | (syntax-rules () | |
133 | ((_ name open read write close) | |
134 | (define name | |
135 | (make-server-impl 'name open read write close))))) | |
136 | ||
137 | (define (lookup-server-impl impl) | |
138 | (cond | |
139 | ((server-impl? impl) impl) | |
140 | ((symbol? impl) | |
141 | (let ((impl (module-ref (resolve-module `(web server ,impl)) impl))) | |
142 | (if (server-impl? impl) | |
143 | impl | |
144 | (error "expected a server impl in module" `(web server ,impl))))) | |
145 | (else | |
146 | (error "expected a server-impl or a symbol" impl)))) | |
147 | ||
148 | ;; -> server | |
149 | (define (open-server impl open-params) | |
150 | (apply (server-impl-open impl) open-params)) | |
151 | ||
152 | ;; -> (keep-alive client request body | keep-alive #f #f #f) | |
153 | (define (read-client impl server keep-alive) | |
154 | (call-with-error-handling | |
155 | (lambda () | |
156 | ((server-impl-read impl) server keep-alive)) | |
157 | #:pass-keys '(quit interrupt) | |
158 | #:on-error (if (batch-mode?) 'pass 'debug) | |
159 | #:post-error | |
160 | (lambda (k . args) | |
161 | (warn "Error while accepting client" k args) | |
c6371902 | 162 | (values keep-alive #f #f #f)))) |
79ef79ee | 163 | |
af0da6eb AW |
164 | (define (call-with-encoded-output-string charset proc) |
165 | (if (and (string-ci=? charset "utf-8") #f) | |
166 | ;; I don't know why, but this appears to be faster; at least for | |
167 | ;; examples/debug-sxml.scm (650 reqs/s versus 510 reqs/s). | |
168 | (string->utf8 (call-with-output-string proc)) | |
169 | (call-with-values | |
170 | (lambda () | |
171 | (open-bytevector-output-port)) | |
172 | (lambda (port get-bytevector) | |
173 | (set-port-encoding! port charset) | |
174 | (proc port) | |
175 | (get-bytevector))))) | |
176 | ||
d9f00c3d | 177 | (define (encode-string str charset) |
af0da6eb AW |
178 | (if (string-ci=? charset "utf-8") |
179 | (string->utf8 str) | |
180 | (call-with-encoded-output-string charset | |
181 | (lambda (port) | |
182 | (display str port))))) | |
d9f00c3d | 183 | |
79ef79ee AW |
184 | ;; -> response body |
185 | (define (sanitize-response request response body) | |
d9f00c3d AW |
186 | (cond |
187 | ((list? response) | |
c6371902 AW |
188 | (sanitize-response request |
189 | (build-response #:version (request-version request) | |
190 | #:headers response) | |
191 | body)) | |
192 | ((not (equal? (request-version request) (response-version response))) | |
193 | (sanitize-response request | |
194 | (adapt-response-version response | |
195 | (request-version request)) | |
196 | body)) | |
a4342ba8 AW |
197 | ((not body) |
198 | (values response #vu8())) | |
d9f00c3d AW |
199 | ((string? body) |
200 | (let* ((type (response-content-type response | |
201 | '("text/plain"))) | |
202 | (declared-charset (assoc-ref (cdr type) "charset")) | |
af0da6eb | 203 | (charset (or declared-charset "utf-8"))) |
d9f00c3d AW |
204 | (sanitize-response |
205 | request | |
206 | (if declared-charset | |
207 | response | |
208 | (extend-response response 'content-type | |
af0da6eb | 209 | `(,@type ("charset" . ,charset)))) |
d9f00c3d AW |
210 | (encode-string body charset)))) |
211 | ((procedure? body) | |
af0da6eb AW |
212 | (let* ((type (response-content-type response |
213 | '("text/plain"))) | |
214 | (declared-charset (assoc-ref (cdr type) "charset")) | |
215 | (charset (or declared-charset "utf-8"))) | |
216 | (sanitize-response | |
217 | request | |
218 | (if declared-charset | |
219 | response | |
220 | (extend-response response 'content-type | |
221 | `(,@type ("charset" . ,charset)))) | |
222 | (call-with-encoded-output-string charset body)))) | |
d9f00c3d AW |
223 | ((bytevector? body) |
224 | ;; check length; assert type; add other required fields? | |
a4342ba8 AW |
225 | (values (let ((rlen (response-content-length response)) |
226 | (blen (bytevector-length body))) | |
227 | (cond | |
612aa5be AW |
228 | (rlen (if (= rlen blen) |
229 | response | |
230 | (error "bad content-length" rlen blen))) | |
a4342ba8 AW |
231 | ((zero? blen) response) |
232 | (else (extend-response response 'content-length blen)))) | |
d9f00c3d AW |
233 | body)) |
234 | (else | |
235 | (error "unexpected body type")))) | |
79ef79ee | 236 | |
c6371902 AW |
237 | ;; -> response body state |
238 | (define (handle-request handler request body state) | |
239 | (call-with-error-handling | |
240 | (lambda () | |
241 | (call-with-values (lambda () | |
242 | (with-stack-and-prompt | |
243 | (lambda () | |
244 | (apply handler request body state)))) | |
245 | (lambda (response body . state) | |
246 | (call-with-values (lambda () | |
8bf6cfea | 247 | (debug-elapsed 'handler) |
c6371902 AW |
248 | (sanitize-response request response body)) |
249 | (lambda (response body) | |
8bf6cfea | 250 | (debug-elapsed 'sanitize) |
c6371902 AW |
251 | (values response body state)))))) |
252 | #:pass-keys '(quit interrupt) | |
253 | #:on-error (if (batch-mode?) 'pass 'debug) | |
254 | #:post-error | |
255 | (lambda (k . args) | |
256 | (warn "Error handling request" k args) | |
257 | (values (build-response #:code 500) #f state)))) | |
258 | ||
79ef79ee AW |
259 | ;; -> (#f | client) |
260 | (define (write-client impl server client response body) | |
261 | (call-with-error-handling | |
262 | (lambda () | |
263 | ((server-impl-write impl) server client response body)) | |
264 | #:pass-keys '(quit interrupt) | |
265 | #:on-error (if (batch-mode?) 'pass 'debug) | |
266 | #:post-error | |
267 | (lambda (k . args) | |
268 | (warn "Error while writing response" k args) | |
269 | #f))) | |
270 | ||
271 | ;; -> unspecified values | |
272 | (define (close-server impl server) | |
273 | ((server-impl-close impl) server)) | |
274 | ||
275 | (define call-with-sigint | |
276 | (if (not (provided? 'posix)) | |
277 | (lambda (thunk handler-thunk) (thunk)) | |
278 | (lambda (thunk handler-thunk) | |
279 | (let ((handler #f)) | |
280 | (catch 'interrupt | |
281 | (lambda () | |
282 | (dynamic-wind | |
283 | (lambda () | |
284 | (set! handler | |
285 | (sigaction SIGINT (lambda (sig) (throw 'interrupt))))) | |
286 | thunk | |
287 | (lambda () | |
288 | (if handler | |
289 | ;; restore Scheme handler, SIG_IGN or SIG_DFL. | |
290 | (sigaction SIGINT (car handler) (cdr handler)) | |
291 | ;; restore original C handler. | |
292 | (sigaction SIGINT #f))))) | |
293 | (lambda (k . _) (handler-thunk))))))) | |
294 | ||
295 | (define (with-stack-and-prompt thunk) | |
296 | (call-with-prompt (default-prompt-tag) | |
297 | (lambda () (start-stack #t (thunk))) | |
298 | (lambda (k proc) | |
299 | (with-stack-and-prompt (lambda () (proc k)))))) | |
300 | ||
301 | (define (and-cons x xs) | |
302 | (if x (cons x xs) xs)) | |
303 | ||
304 | ;; -> new keep-alive new-state | |
305 | (define (serve-one-client handler impl server keep-alive state) | |
8bf6cfea | 306 | (debug-elapsed 'serve-again) |
79ef79ee AW |
307 | (call-with-values |
308 | (lambda () | |
309 | (read-client impl server keep-alive)) | |
310 | (lambda (keep-alive client request body) | |
8bf6cfea | 311 | (debug-elapsed 'read-client) |
79ef79ee AW |
312 | (if client |
313 | (call-with-values | |
314 | (lambda () | |
c6371902 AW |
315 | (handle-request handler request body state)) |
316 | (lambda (response body state) | |
8bf6cfea | 317 | (debug-elapsed 'handle-request) |
c6371902 | 318 | (values |
8bf6cfea AW |
319 | (and-cons (let ((x (write-client impl server client response body))) |
320 | (debug-elapsed 'write-client) | |
321 | x) | |
c6371902 AW |
322 | keep-alive) |
323 | state))) | |
79ef79ee AW |
324 | (values keep-alive state))))) |
325 | ||
326 | (define* (run-server handler #:optional (impl 'http) (open-params '()) | |
327 | . state) | |
328 | (let* ((impl (lookup-server-impl impl)) | |
329 | (server (open-server impl open-params))) | |
330 | (call-with-sigint | |
331 | (lambda () | |
332 | (let lp ((keep-alive '()) (state state)) | |
333 | (call-with-values | |
334 | (lambda () | |
335 | (serve-one-client handler impl server keep-alive state)) | |
336 | (lambda (new-keep-alive new-state) | |
337 | (lp new-keep-alive new-state))))) | |
338 | (lambda () | |
339 | (close-server impl server) | |
340 | (values))))) |