scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

first shot on servlet's new form interface

This commit is contained in:
interp 2002-09-24 16:56:00 +00:00
parent 8e4a0c2872
commit 9f2754cff5
4 changed files with 247 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
scheme/httpd/surflets/packages.scm
View File

@ -104,9 +104,19 @@
send/finish
send-html/suspend
send-html/finish
send-html
form-query
extract-bindings
extract-single-binding))
extract-single-binding
make-text-input-field
make-password-input-field
make-number-input-field
make-textarea-input-field
make-select-input-field
make-submit-button
input-field-value
make-callback))
(define-structure plugin-utilities plugin-utilities-interface
(open servlet-handler/plugin
@ -114,6 +124,10 @@
parse-html-forms
sxml-to-html ;SXML->HTML
srfi-1 ;FILTER
sxml-tree-trans
url
httpd-request
define-record-types
scsh
scheme)
(files utilities))

218
scheme/httpd/surflets/utilities.scm
View File

@ -6,9 +6,7 @@
(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)))))))))
(servlet-XML->HTML out (html-tree-maker new-url)))))))
(define (send-html/finish html-tree)
(do-sending send/finish html-tree))
@ -16,13 +14,10 @@
(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 (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
@ -57,4 +52,207 @@
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))))))

53
scheme/httpd/surflets/web-server/root/surflets/add2.scm
View File

@ -6,41 +6,27 @@
scheme)
(begin
(define (add-call-back continue)
(make-call-back
(lambda (bindings)
(continue
(string->number (extract-single-binding bindings "number"))))))
(define (make-call-back 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)))))
;; I know the names and the types from God
(function bindings)))))
(define number-input-field (make-number-input-field '(maxlength 10)))
(define (get-number input-text . maybe-title)
(let* ((title (if (pair? maybe-title) (car maybe-title) #f))
(result (call-with-current-continuation
(lambda (exit)
(send-html
(lambda (new-url)
`(html ,(if title
`(title ,title) '())
(body
,(if title `(h1 ,title) '())
(p (a (@ href "reset") "click here to reset server's plugin cache"))
(p
(form (@ (method "get")
(action ,(add-call-back exit)))
,input-text
(input (@ (type "text")
(name "number"))
(input (@ (type "submit"))))))))))))))
(result
(send-html/suspend
(lambda (new-url)
`(html ,(if title
`(title ,title) '())
(body
,(if title `(h1 ,title) '())
(p (a (@ href "reset")
"click here to reset server's plugin cache"))
(p
(form ,new-url
,input-text
,number-input-field
,(make-submit-button)))))))))
(if result
result
(input-field-value number-input-field
(form-query (http-url:search (request:url result))))
(get-number input-text "Please enter a number"))))
(define (get-number1)
@ -52,11 +38,12 @@
(define (main req)
(let ((number1 (get-number1))
(number2 (get-number2)))
(send-html/finish
(send-html
`(html (title "Result")
(body (h1 "Result")
(p ,(number->string (+ number1 number2)))
(a (@ (href "/")) "done"))))
"this will never be evaluated"))
"this string will never be evaluated"))
))

15
scheme/httpd/surflets/web-server/root/surflets/test.scm
View File

@ -1,16 +1,9 @@
(define-structure plugin plugin-interface
(open scsh
scheme
plugin-utilities
httpd-responses)
(begin
(define (main send/suspend)
(make-response
http-status/ok
(status-code->text http-status/ok)
(time)
"text/html"
'()
(make-writer-body
(lambda (out options)
(format out "<HTML><BODY><H1>THIS IS FROM SERVLET</H1></BODY></HTML>~%")))))))
(define (main req)
(send-html/finish
'(html (body (h1 "This is from servlet")))))))