62 lines
1.7 KiB
Scheme
62 lines
1.7 KiB
Scheme
|
;; utilities for plugin (servlets)
|
||
|
|
;; Copyright 2002, Andreas Bernauer
|
||
|
|
|
||
|
|
(define (send-html/suspend html-tree-maker)
|
||
|
|
(send/suspend
|
||
|
|
(lambda (new-url)
|
||
|
|
(make-usual-html-response
|
||
|
|
(lambda (out options)
|
||
|
|
(with-current-output-port* ; FIXME: will change in further revision
|
||
|
|
out
|
||
|
|
(lambda () (SXML->HTML (html-tree-maker new-url)))))))))
|
||
|
|
|
||
|
|
(define (send-html/finish html-tree)
|
||
|
|
(do-sending send/finish html-tree))
|
||
|
|
|
||
|
|
(define (send-html html-tree)
|
||
|
|
(do-sending send html-tree))
|
||
|
|
|
||
|
|
(define (do-sending sending-version html-tree)
|
||
|
|
(sending-version
|
||
|
|
(make-usual-html-response
|
||
|
|
(lambda (out options)
|
||
|
|
(with-current-output-port* ; FIXME: will change in further revision
|
||
|
|
out
|
||
|
|
(lambda () (SXML->HTML html-tree)))))))
|
||
|
|
(
|
||
|
|
|
||
|
|
(define (make-usual-html-response writer-proc)
|
||
|
|
(make-response
|
||
|
|
http-status/ok
|
||
|
|
(status-code->text http-status/ok)
|
||
|
|
(time)
|
||
|
|
"text/html"
|
||
|
|
'()
|
||
|
|
(make-writer-body writer-proc)))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; from cgi-script:
|
||
|
|
;;; Return the form data as an alist of decoded strings.
|
||
|
|
;;; So a query string like "button=on&reply=Oh,%20yes" becomes alist
|
||
|
|
;;; (("button" . "on") ("reply" . "Oh, yes"))
|
||
|
|
;;; This only works for GET and POST methods.
|
||
|
|
|
||
|
|
(define form-query parse-html-form-query)
|
||
|
|
|
||
|
|
(define (extract-bindings bindings key)
|
||
|
|
(let ((key (if (symbol? key) (symbol->string key) key)))
|
||
|
|
(filter (lambda (binding)
|
||
|
|
(equal? (car binding) key))
|
||
|
|
bindings)))
|
||
|
|
|
||
|
|
(define (extract-single-binding bindings key)
|
||
|
|
(let ((key-bindings (extract-bindings bindings key)))
|
||
|
|
(if (= 1 (length key-bindings))
|
||
|
|
(cdar key-bindings)
|
||
|
|
(error "extract-one-binding: more than one or zero bindings found"
|
||
|
|
(length key-bindings)
|
||
|
|
key bindings))))
|
||
|
|
|
||
|
|
|
||
|
|
|