Commit | Line | Data |
---|---|---|
ee3a800f AW |
1 | ;;; Commentary: |
2 | ||
3 | ;;; A simple debugging server that responds to all responses with a | |
4 | ;;; table containing the headers given in the request. | |
5 | ;;; | |
6 | ;;; As a novelty, this server uses a little micro-framework to build up | |
7 | ;;; the response as SXML. Instead of a string, the `respond' helper | |
8 | ;;; returns a procedure for the body, which allows the `(web server)' | |
9 | ;;; machinery to collect the output as a bytevector in the desired | |
10 | ;;; encoding, instead of building an intermediate output string. | |
11 | ;;; | |
12 | ;;; In the future this will also allow for chunked transfer-encoding, | |
13 | ;;; for HTTP/1.1 clients. | |
14 | ||
15 | ;;; Code: | |
16 | ||
17 | (use-modules (web server) | |
18 | (web request) | |
19 | (web response) | |
20 | (sxml simple)) | |
21 | ||
22 | (define html5-doctype "<!DOCTYPE html>\n") | |
23 | (define default-title "Hello hello!") | |
24 | ||
25 | (define* (templatize #:key (title "No title") (body '((p "No body")))) | |
26 | `(html (head (title ,title)) | |
27 | (body ,@body))) | |
28 | ||
29 | (define* (respond #:optional body #:key | |
30 | (status 200) | |
31 | (title default-title) | |
32 | (doctype html5-doctype) | |
0acc595b AW |
33 | (content-type-params '((charset . "utf-8"))) |
34 | (content-type 'text/html) | |
ee3a800f AW |
35 | (extra-headers '()) |
36 | (sxml (and body (templatize #:title title #:body body)))) | |
37 | (values (build-response | |
38 | #:code status | |
39 | #:headers `((content-type . (,content-type ,@content-type-params)) | |
40 | ,@extra-headers)) | |
41 | (lambda (port) | |
42 | (if sxml | |
43 | (begin | |
44 | (if doctype (display doctype port)) | |
45 | (sxml->xml sxml port)))))) | |
46 | ||
47 | (define (debug-page request body) | |
48 | (respond `((h1 "hello world!") | |
49 | (table | |
50 | (tr (th "header") (th "value")) | |
51 | ,@(map (lambda (pair) | |
52 | `(tr (td (tt ,(with-output-to-string | |
53 | (lambda () (display (car pair)))))) | |
54 | (td (tt ,(with-output-to-string | |
55 | (lambda () | |
56 | (write (cdr pair)))))))) | |
57 | (request-headers request)))))) | |
58 | ||
59 | (run-server debug-page) |