+ servlet-handler/admin structure gives runtime
access to servlet-handler options + several constructors for form input fields
This commit is contained in:
interp
parent
db6b607d0f
commit
2579598783
|
|
@ -74,9 +74,16 @@
|
|||
send ;just send (no finish, no suspend)
|
||||
))
|
||||
|
||||
(define-interface servlet-handler/admin-interface
|
||||
(export get-loaded-plugins
|
||||
unload-plugin
|
||||
set-instance-lifetime!
|
||||
get-instance-lifetime))
|
||||
|
||||
(define-structures
|
||||
((servlet-handler servlet-handler-interface)
|
||||
(servlet-handler/plugin servlet-handler/plugin-interface))
|
||||
(servlet-handler/plugin servlet-handler/plugin-interface)
|
||||
(servlet-handler/admin servlet-handler/admin-interface))
|
||||
(open httpd-responses
|
||||
httpd-request
|
||||
uri ;URI-PATH-LIST->PATH
|
||||
|
|
@ -96,6 +103,7 @@
|
|||
defrec-package ;DEFINE-RECORD
|
||||
threads ;SLEEP
|
||||
thread-fluids ;FORK-THREAD
|
||||
sxml-to-html ;SXML->HTML
|
||||
scsh ;regexp et al.
|
||||
scheme
|
||||
)
|
||||
|
|
@ -116,13 +124,17 @@
|
|||
make-input-field
|
||||
make-upper-input-field
|
||||
make-text-input-field
|
||||
make-hidden-input-field
|
||||
make-password-input-field
|
||||
make-number-input-field
|
||||
make-textarea-input-field
|
||||
make-select-input-field
|
||||
make-select-input-fields
|
||||
make-checkbox-input-field
|
||||
make-radio-input-fields
|
||||
|
||||
make-submit-button
|
||||
make-reset-button
|
||||
make-image-button
|
||||
input-field-value
|
||||
make-callback))
|
||||
|
||||
|
|
|
|||
|
|
@ -201,16 +201,93 @@
|
|||
(define (make-upper-input-field transformer HTML-tree)
|
||||
(list 'input-field (real-make-input-field #f transformer HTML-tree #t)))
|
||||
|
||||
;; PRED-LIST contains list of predicates that recognizes optional
|
||||
;; leading parameters. FURTHER-ATTRIBUTES is the optional parameter
|
||||
;; list as got by procedure call. PREFIX-OPTIONALS returns two values:
|
||||
;; a list of the same length as PRED-LIST and a list containing the
|
||||
;; left arguments that did not fit the predicates.
|
||||
;;
|
||||
;; With the help of PREFIX-OPTIONALS you can define a function
|
||||
;; like `make-submit-button [string] [further-attributes]' this way:
|
||||
;; (define (make-submit-button . args)
|
||||
;; (receive (params rest-args)
|
||||
;; (prefix-optionals (list string? XML-attribute?) args)
|
||||
;; (if (pair? rest-args)
|
||||
;; (error "too many arguments to make-submit-button))
|
||||
;; (let ((value (first params))
|
||||
;; (attributes (second params)))
|
||||
;; ...))))
|
||||
;;
|
||||
(define (typed-optionals pred-list args)
|
||||
(let loop ((results '())
|
||||
(pred-list pred-list)
|
||||
(args args))
|
||||
(cond
|
||||
((null? pred-list)
|
||||
(values (reverse results) args))
|
||||
((null? args)
|
||||
(values (rev-append results (make-list (length pred-list) #f)) '()))
|
||||
(((car pred-list) (car args))
|
||||
(loop (cons (car args) results)
|
||||
(cdr pred-list)
|
||||
(cdr args)))
|
||||
(else
|
||||
(loop (cons #f results)
|
||||
(cdr pred-list)
|
||||
args)))))
|
||||
|
||||
|
||||
(define-syntax optionals
|
||||
(lambda (exp rename compare)
|
||||
(let ((%receive (rename 'receive))
|
||||
(%typed-optionals (rename 'typed-optionals))
|
||||
(%list (rename 'list))
|
||||
(%if (rename 'if))
|
||||
(%pair? (rename 'pair?))
|
||||
(%error (rename 'error))
|
||||
(%let (rename 'let))
|
||||
(%list-ref (rename 'list-ref))
|
||||
|
||||
(args (cadr exp))
|
||||
(var-list (caddr exp))
|
||||
(body (cadddr exp)))
|
||||
`(,%receive (params rest-args)
|
||||
(,%typed-optionals (,%list ,@(map cadr var-list)) ,args)
|
||||
(,%if (pair? rest-args)
|
||||
(,%error "optionals: too many arguments and/or argument type mismatch")
|
||||
(,%let (,@(let loop ((counter 0)
|
||||
(var-list var-list))
|
||||
(if (null? var-list)
|
||||
'()
|
||||
(cons (cons (caar var-list) `((,%list-ref params ,counter)))
|
||||
(loop (+ 1 counter)
|
||||
(cdr var-list))))))
|
||||
,body))))))
|
||||
|
||||
;; from uri.scm
|
||||
(define (rev-append a b) ; (append (reverse a) b)
|
||||
(let rev-app ((a a) (b b)) ; Should be defined in a list-proc
|
||||
(if (pair? a) ; package, not here.
|
||||
(rev-app (cdr a) (cons (car a) b))
|
||||
b)))
|
||||
|
||||
(define (make-text-input-field . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "text")))
|
||||
(optionals maybe-further-attributes
|
||||
((attributes XML-attribute?))
|
||||
(make-input-field name
|
||||
identity
|
||||
`(input (@ (type "text")
|
||||
(name ,name)
|
||||
,@maybe-further-attributes)))))
|
||||
;; this will insert a list, but
|
||||
;; XML->HTML doesn't care about it
|
||||
,(and attributes (cdr attributes))
|
||||
))))))
|
||||
|
||||
(define (make-number-input-field . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "number")))
|
||||
(optionals maybe-further-attributes
|
||||
((attributes XML-attribute?))
|
||||
(make-input-field
|
||||
name
|
||||
(lambda (string)
|
||||
|
|
@ -218,97 +295,141 @@
|
|||
(error "wrong type")))
|
||||
`(input (@ (type "text")
|
||||
(name ,name)
|
||||
,@maybe-further-attributes)))))
|
||||
,(and attributes (cdr attributes))))))))
|
||||
|
||||
(define (make-password-input-field . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "password")))
|
||||
(optionals maybe-further-attributes
|
||||
((attributes XML-attribute?))
|
||||
(make-input-field
|
||||
name
|
||||
identity
|
||||
`(input (@ (type "password")
|
||||
(name ,name)
|
||||
,@maybe-further-attributes)))))
|
||||
,@(and attributes (cdr 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)
|
||||
'())))
|
||||
(let ((name (generate-input-field-name "textarea")))
|
||||
(optionals maybe-further-attributes
|
||||
((default-text string?)
|
||||
(attributes XML-attribute?))
|
||||
(make-input-field
|
||||
name
|
||||
identity
|
||||
`(textarea (@ (type "textarea")
|
||||
(name ,name)
|
||||
,@maybe-further-attributes)
|
||||
,default-text))))
|
||||
,(and attributes (cdr attributes)))
|
||||
,(and default-text))))))
|
||||
|
||||
(define (make-select-input-field options . maybe-further-attributes)
|
||||
;(make-select-input-fields '("this" "that" "those") '(@ ((id "sushi"))))
|
||||
;(make-select-input-fields '("this" ("that" '(@ (selected))) "those"))
|
||||
;; dropdown: (size 1)
|
||||
;; multiple choice: (multiple)
|
||||
;; preselected option: (selected)
|
||||
;; changed return value: (value new-value)
|
||||
;; returns a select input field with several options
|
||||
(define (make-select-input-fields options . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "select")))
|
||||
(optionals maybe-further-attributes
|
||||
((attributes XML-attribute?))
|
||||
(make-input-field
|
||||
name
|
||||
(lambda (select)
|
||||
select) ;FIXME[extension] refer to list elements
|
||||
`(select (@ ((name ,name)
|
||||
,@maybe-further-attributes))
|
||||
,(and attributes (cdr attributes))))
|
||||
#\newline
|
||||
,@(map (lambda (option)
|
||||
(if (pair? option) ; with attributes?
|
||||
`(option (@ ,@(cdr option)) ,(car option))
|
||||
`(option ,option)))
|
||||
options)))))
|
||||
(cond
|
||||
((string? option)
|
||||
(list 'option option))
|
||||
((list? option)
|
||||
(cond
|
||||
((null? (cdr option))
|
||||
`(option ,option))
|
||||
((XML-attribute? (cadr option)) ; with attributes?
|
||||
`(option ,(cadr option) ,(car option)))
|
||||
(else
|
||||
(error "not an attribute" (cdr option)))))
|
||||
(else
|
||||
(error "not an option" option))))
|
||||
options))))))
|
||||
|
||||
;; returns a *list* of radio buttons
|
||||
(define (make-radio-input-fields values . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "radio")))
|
||||
(optionals maybe-further-attributes
|
||||
((attributes XML-attribute?))
|
||||
(map (lambda (value)
|
||||
(let ((value-value (if (pair? value) (car value) value))
|
||||
(value-attributes (if (pair? value)
|
||||
(if (XML-attribute? (cadr value))
|
||||
(cdadr value)
|
||||
(error "not an attribute" cadr value))
|
||||
#f)))
|
||||
(make-input-field
|
||||
name
|
||||
(lambda (select)
|
||||
select) ;FIXME refer to list elements
|
||||
`(input (@ ((type "radio")
|
||||
(name ,name)
|
||||
(value ,value-value)
|
||||
,(and value-attributes)
|
||||
,(and attributes (cdr attributes))))))))
|
||||
values))))
|
||||
|
||||
;; returns a checkbox input field
|
||||
(define (make-checkbox-input-field . maybe-further-attributes)
|
||||
(let* ((name (generate-input-field-name "checkbox"))
|
||||
(value (if (and (pair? maybe-further-attributes)
|
||||
(string? (car maybe-further-attributes)))
|
||||
(car maybe-further-attributes)
|
||||
#f))
|
||||
(further-attributes (if value
|
||||
(cdr maybe-further-attributes)
|
||||
maybe-further-attributes)))
|
||||
(let* ((name (generate-input-field-name "checkbox")))
|
||||
(optionals maybe-further-attributes
|
||||
((value (lambda (a) (or (string? a)
|
||||
(number? a)
|
||||
(symbol? a))))
|
||||
(attributes XML-attribute?))
|
||||
(make-input-field
|
||||
name
|
||||
identity
|
||||
`(input (@ ((type "checkbox")
|
||||
(name ,name)
|
||||
,(if value `(value ,value) '())
|
||||
,@further-attributes))))))
|
||||
,(and attributes (cdr attributes)))))))))
|
||||
|
||||
|
||||
;; 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")
|
||||
(define (make-hidden-input-field value . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "hidden")))
|
||||
(optionals maybe-further-attributes
|
||||
((attributes XML-attribute?))
|
||||
(make-input-field name
|
||||
identity
|
||||
`(input (@ (type "hidden")
|
||||
(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))))
|
||||
|
||||
|
||||
|
||||
|
||||
(value ,value)
|
||||
,(and attributes (cdr attributes))))))))
|
||||
|
||||
(define (make-button type button-caption attributes)
|
||||
`(input (@ (type ,type)
|
||||
,(and button-caption `(value ,button-caption))
|
||||
,(and attributes (cdr attributes)))))
|
||||
|
||||
(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))))
|
||||
(optionals maybe-further-attributes
|
||||
((button-caption (lambda (a) (or (string? a)
|
||||
(symbol? a))))
|
||||
(attributes XML-attribute?))
|
||||
(make-button "submit" button-caption attributes)))
|
||||
|
||||
(define (make-reset-button . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((button-caption (lambda (a) (or (string? a)
|
||||
(symbol? a))))
|
||||
(attributes XML-attribute?))
|
||||
(make-button "reset" button-caption attributes)))
|
||||
|
||||
(define (make-image-button image-source . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((attributes XML-attribute?))
|
||||
(make-button "image" #f `(@ (src ,image-source)
|
||||
,@(if attributes (cdr attributes) '())))))
|
||||
|
||||
(define (input-field-value input-field bindings)
|
||||
(let ((input-field (cadr input-field)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue