313 lines
8.6 KiB
Scheme
313 lines
8.6 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)
|
|
(servlet-XML->HTML out (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 send html-tree)
|
|
(send (make-usual-html-response
|
|
(lambda (out options)
|
|
(servlet-XML->HTML out 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))))
|
|
|
|
|
|
;; adapted from Oleg's SXML-tree-trans.scm
|
|
;; extended by port argument
|
|
;; #t: current-output-port
|
|
;; #f: string
|
|
;; port: port
|
|
;; else: error
|
|
(define (formated-reply port . fragments)
|
|
(cond
|
|
((not port)
|
|
(call-with-string-output-port
|
|
(lambda (port)
|
|
(real-formated-reply port fragments))))
|
|
((eq? port #t)
|
|
(real-formated-reply (current-output-port) fragments))
|
|
((output-port? port)
|
|
(real-formated-reply port fragments))
|
|
(else
|
|
(error "invalid port argument to FORMATED-REPLY" port))))
|
|
|
|
(define (real-formated-reply port fragments)
|
|
(let loop ((fragments fragments) (result #f))
|
|
(cond
|
|
((null? fragments) result)
|
|
((not (car fragments)) (loop (cdr fragments) result))
|
|
((null? (car fragments)) (loop (cdr fragments) result))
|
|
((pair? (car fragments))
|
|
(loop (cdr fragments) (loop (car fragments) result)))
|
|
((procedure? (car fragments))
|
|
((car fragments))
|
|
(loop (cdr fragments) #t))
|
|
(else
|
|
(display (car fragments) port)
|
|
(loop (cdr fragments) #t)))))
|
|
|
|
;; adapted from Oleg's SXML-to-HTML.scm
|
|
;; extended by additional port argument
|
|
(define (servlet-XML->HTML out html-tree)
|
|
(formated-reply out
|
|
(reformat html-tree)))
|
|
|
|
(define (reformat html-tree)
|
|
(pre-post-order
|
|
html-tree
|
|
`(
|
|
;; Universal transformation rules. Works for every HTML,
|
|
;; present and future
|
|
,@default-rules
|
|
(input-field
|
|
*preorder*
|
|
. ,(lambda (trigger input-field)
|
|
(reformat (input-field-HTML-tree input-field))))
|
|
|
|
(servlet-form
|
|
;; Must do something to prevent the callback-function string to
|
|
;; be HTML escaped.
|
|
*preorder*
|
|
. ,(lambda (trigger call-back-function . elems)
|
|
(if (and (pair? elems)
|
|
(XML-attribute? (car elems)))
|
|
(make-servlet-form call-back-function (cdar elems) (cdr elems))
|
|
(make-servlet-form call-back-function'() elems)))))
|
|
))
|
|
|
|
(define (make-servlet-form call-back-function attributes elems)
|
|
`("<form" ,@(map (lambda (attribute-value)
|
|
((enattr (car attribute-value)) (cadr attribute-value)))
|
|
`((method "GET")
|
|
(action ,call-back-function)
|
|
,@attributes))
|
|
#\> #\newline
|
|
,(reformat elems)
|
|
"</form>"))
|
|
|
|
(define (XML-attribute? thing)
|
|
(and (pair? thing)
|
|
(eq? '@ (car thing))))
|
|
|
|
(define attribute-rule
|
|
`(@ ; local override for attributes
|
|
((*default*
|
|
. ,(lambda (attr-key . value) ((enattr attr-key) value))))
|
|
. ,(lambda (trigger . value) (list '@ value))))
|
|
|
|
(define text-rule
|
|
`(*text*
|
|
. ,(lambda (trigger str)
|
|
(if (string? str) (string->goodHTML str) str))))
|
|
|
|
(define URL-rule
|
|
(cons 'URL
|
|
(lambda (tag URI text) (list "<a href=\"" URI "\">" text "</a>"))))
|
|
|
|
(define default-rules
|
|
`(,attribute-rule
|
|
(*default*
|
|
. ,(lambda (tag . elems) (apply (entag tag) elems)))
|
|
,text-rule
|
|
,URL-rule))
|
|
|
|
(define (make-callback function)
|
|
(call-with-current-continuation
|
|
(lambda (exit)
|
|
(let* ((req (send/suspend (lambda (new-url)
|
|
(exit new-url))))
|
|
(bindings (form-query (http-url:search (request:url req)))))
|
|
(function bindings)))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; input-fields
|
|
;;; defines input-fields for servlets
|
|
|
|
(define-record-type input-field :input-field
|
|
(real-make-input-field name transformer HTML-tree)
|
|
input-field?
|
|
(name input-field-name)
|
|
(transformer input-field-transformer)
|
|
(attributes input-field-attributes)
|
|
(HTML-tree input-field-HTML-tree))
|
|
|
|
(define-record-discloser :input-field
|
|
(lambda (input-field)
|
|
(list 'input-field (input-field-name input-field))))
|
|
|
|
;; FIXME: consider creating small names
|
|
(define generate-input-field-name
|
|
(let ((id 0))
|
|
(lambda (type-string)
|
|
(set! id (+ 1 id))
|
|
(string-append type-string (number->string id)))))
|
|
|
|
(define identity (lambda (a) a))
|
|
|
|
(define (make-input-field name transformer HTML-tree)
|
|
(list 'input-field (real-make-input-field name transformer HTML-tree)))
|
|
|
|
(define (make-text-input-field . maybe-further-attributes)
|
|
(let ((name (generate-input-field-name "text")))
|
|
(make-input-field name
|
|
identity
|
|
`(input (@ (type "text")
|
|
(name ,name)
|
|
,@maybe-further-attributes)))))
|
|
|
|
(define (make-number-input-field . maybe-further-attributes)
|
|
(let ((name (generate-input-field-name "number")))
|
|
(make-input-field
|
|
name
|
|
(lambda (string)
|
|
(or (string->number string)
|
|
(error "wrong type")))
|
|
`(input (@ (type "text")
|
|
(name ,name)
|
|
,@maybe-further-attributes)))))
|
|
|
|
(define (make-password-input-field . maybe-further-attributes)
|
|
(let ((name (generate-input-field-name "password")))
|
|
(make-input-field
|
|
name
|
|
identity
|
|
`(input (@ (type "password")
|
|
(name ,name)
|
|
,@maybe-further-attributes)))))
|
|
|
|
(define (make-textarea-input-field . maybe-further-attributes)
|
|
(let ((name (generate-input-field-name "textarea"))
|
|
(default-text (if (and (pair? maybe-further-attributes)
|
|
(string? (car maybe-further-attributes)))
|
|
(car maybe-further-attributes)
|
|
'())))
|
|
(make-input-field
|
|
name
|
|
identity
|
|
`(textarea (@ (type "textarea")
|
|
(name ,name)
|
|
,@maybe-further-attributes)
|
|
,default-text))))
|
|
|
|
(define (make-select-input-field options . maybe-further-attributes)
|
|
(let ((name (generate-input-field-name "select")))
|
|
(make-input-field
|
|
name
|
|
(lambda (select)
|
|
select) ;FIXME[extension] refer to list elements
|
|
`(select (@ ((name ,name)
|
|
,@maybe-further-attributes))
|
|
#\newline
|
|
,@(map (lambda (option)
|
|
(if (pair? option) ; with attributes?
|
|
`(option (@ ,@(cdr option)) ,(car option))
|
|
`(option ,option)))
|
|
options)))))
|
|
|
|
;; in work
|
|
(define (make-radio-input-field values . maybe-further-attributes)
|
|
(let ((name (generate-input-field-name "radio")))
|
|
(make-input-field
|
|
name
|
|
(lambda (select)
|
|
select) ;FIXME refer to list elements
|
|
(map (lambda (value)
|
|
`((input (@ ((type "radio")
|
|
(name ,name)
|
|
,@maybe-further-attributes
|
|
,(if (pair? value) ; with attributes?
|
|
(cdr value)
|
|
'())))) ;FIXME: add value field
|
|
,(if (pair? value) ; with attributes?
|
|
(car value)
|
|
value)))
|
|
values))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (make-submit-button . maybe-further-attributes)
|
|
(if (and (pair? maybe-further-attributes)
|
|
(string? (car maybe-further-attributes)))
|
|
`(input (@ (type "submit")
|
|
(value ,(car maybe-further-attributes))
|
|
,@maybe-further-attributes))
|
|
`(input (@ (type "submit")
|
|
,@maybe-further-attributes))))
|
|
|
|
(define (input-field-value input-field bindings)
|
|
(let ((input-field (cadr input-field)))
|
|
(cond
|
|
((assoc (input-field-name input-field) bindings) =>
|
|
(lambda (binding)
|
|
((input-field-transformer input-field) (cdr binding))))
|
|
(else
|
|
(error "no such input-field" input-field bindings)))))
|
|
|
|
|
|
|
|
|
|
;;; tests
|
|
(define number-input-field (make-number-input-field))
|
|
|
|
(define test
|
|
`(html
|
|
(title "My Title")
|
|
(body
|
|
(p (URL "reset" "click here to reset"))
|
|
(p (form "return-URI" (table (tr (td "Enter a number ") (td ,number-input-field )))
|
|
,(make-submit-button))))))
|
|
|
|
|
|
|