diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm index 4b98341..8e2e1ae 100644 --- a/scheme/httpd/surflets/packages.scm +++ b/scheme/httpd/surflets/packages.scm @@ -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)) diff --git a/scheme/httpd/surflets/utilities.scm b/scheme/httpd/surflets/utilities.scm index fa375d3..00ab6ad 100644 --- a/scheme/httpd/surflets/utilities.scm +++ b/scheme/httpd/surflets/utilities.scm @@ -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 "
\n" (parse-form-elems (cdr elems)) "
") + (list "\">\n" (parse-form-elems elems) "")))))) + + ))) + +(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 "" text "")))) + ) + +(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)))))) diff --git a/scheme/httpd/surflets/web-server/root/surflets/add2.scm b/scheme/httpd/surflets/web-server/root/surflets/add2.scm index 130f3d1..9f4300c 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/add2.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/add2.scm @@ -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")) )) \ No newline at end of file diff --git a/scheme/httpd/surflets/web-server/root/surflets/test.scm b/scheme/httpd/surflets/web-server/root/surflets/test.scm index da2b9ba..a82473d 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/test.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/test.scm @@ -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 "

THIS IS FROM SERVLET

~%"))))))) - \ No newline at end of file + (define (main req) + (send-html/finish + '(html (body (h1 "This is from servlet")))))))