mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
0acc595b94
* module/web/http.scm (parse-media-type): Parse media types as symbols.
(parse-key-value-list, parse-param-component, parse-param-list):
Change kons to val-parser. Always parse keys as symbols, and always
either cons, if there is a val, or just have the key, if there is no
val. Easier to explain and just as correct.
(declare-param-list-header!, declare-key-value-list-header!): Adapt to
key-list and param-list kons change.
("Cache-Control", "Pragma", "Transfer-Encoding", "Accept", "Expect")
("TE"): Likewise, adapt.
("Content-Type"): Param keys are symbols.
59 lines
2.1 KiB
Scheme
59 lines
2.1 KiB
Scheme
;;; Commentary:
|
|
|
|
;;; A simple debugging server that responds to all responses with a
|
|
;;; table containing the headers given in the request.
|
|
;;;
|
|
;;; As a novelty, this server uses a little micro-framework to build up
|
|
;;; the response as SXML. Instead of a string, the `respond' helper
|
|
;;; returns a procedure for the body, which allows the `(web server)'
|
|
;;; machinery to collect the output as a bytevector in the desired
|
|
;;; encoding, instead of building an intermediate output string.
|
|
;;;
|
|
;;; In the future this will also allow for chunked transfer-encoding,
|
|
;;; for HTTP/1.1 clients.
|
|
|
|
;;; Code:
|
|
|
|
(use-modules (web server)
|
|
(web request)
|
|
(web response)
|
|
(sxml simple))
|
|
|
|
(define html5-doctype "<!DOCTYPE html>\n")
|
|
(define default-title "Hello hello!")
|
|
|
|
(define* (templatize #:key (title "No title") (body '((p "No body"))))
|
|
`(html (head (title ,title))
|
|
(body ,@body)))
|
|
|
|
(define* (respond #:optional body #:key
|
|
(status 200)
|
|
(title default-title)
|
|
(doctype html5-doctype)
|
|
(content-type-params '((charset . "utf-8")))
|
|
(content-type 'text/html)
|
|
(extra-headers '())
|
|
(sxml (and body (templatize #:title title #:body body))))
|
|
(values (build-response
|
|
#:code status
|
|
#:headers `((content-type . (,content-type ,@content-type-params))
|
|
,@extra-headers))
|
|
(lambda (port)
|
|
(if sxml
|
|
(begin
|
|
(if doctype (display doctype port))
|
|
(sxml->xml sxml port))))))
|
|
|
|
(define (debug-page request body)
|
|
(respond `((h1 "hello world!")
|
|
(table
|
|
(tr (th "header") (th "value"))
|
|
,@(map (lambda (pair)
|
|
`(tr (td (tt ,(with-output-to-string
|
|
(lambda () (display (car pair))))))
|
|
(td (tt ,(with-output-to-string
|
|
(lambda ()
|
|
(write (cdr pair))))))))
|
|
(request-headers request))))))
|
|
|
|
(run-server debug-page)
|