renaming UTILTIES.SCM to SERVLETS.SCM and structure PLUGIN-UTILITIES to SERVLETS
This commit is contained in:
interp
parent
c28d6cf153
commit
1abbed29f0
|
|
@ -1,258 +0,0 @@
|
||||||
;; 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
|
|
||||||
(pre-post-order html-tree
|
|
||||||
;; Universal transformation rules. Work for every HTML,
|
|
||||||
;; present and future
|
|
||||||
`(,@default-rules
|
|
||||||
(form *preorder* .
|
|
||||||
,(lambda (trigger call-back-function . elems)
|
|
||||||
(list "<form method=\"GET\" action=\"" call-back-function
|
|
||||||
(if (and (pair? elems) (pair? (car elems)) (eq? '@ (caar elems)))
|
|
||||||
(list (car elems) "\">\n" (parse-form-elems (cdr elems)) "</form>")
|
|
||||||
(list "\">\n" (parse-form-elems elems) "</form>"))))))
|
|
||||||
|
|
||||||
)))
|
|
||||||
|
|
||||||
(define (parse-form-elems elems)
|
|
||||||
(map (lambda (elem)
|
|
||||||
(if (input-field? elem)
|
|
||||||
(post-order (input-field-HTML-tree elem) default-rules)
|
|
||||||
(post-order elem default-rules)))
|
|
||||||
elems))
|
|
||||||
|
|
||||||
(define text-html-rule
|
|
||||||
`(*text* . ,(lambda (trigger str)
|
|
||||||
(if (string? str) (string->goodHTML str) str))))
|
|
||||||
(define default-rules
|
|
||||||
`((@ ; local override for attributes
|
|
||||||
((*default*
|
|
||||||
. ,(lambda (attr-key . value) ((enattr attr-key) value))))
|
|
||||||
. ,(lambda (trigger . value) (list '@ value)))
|
|
||||||
(*default* . ,(lambda (tag . elems) (apply (entag tag) elems)))
|
|
||||||
,text-html-rule
|
|
||||||
(URL . ,(lambda (tag URI text) (list "<a href=\"" URI "\">" text "</a>"))))
|
|
||||||
)
|
|
||||||
|
|
||||||
(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)))))
|
|
||||||
|
|
||||||
(define-record-type input-field :input-field
|
|
||||||
(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-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)
|
|
||||||
(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))))
|
|
||||||
|
|
||||||
|
|
||||||
(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))))))
|
|
||||||
|
|
||||||
Loading…
Reference in New Issue