HCoop / bpt / guile.git / blame
| 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) |