diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm index caff3c1..25c7fac 100644 --- a/scheme/httpd/surflets/packages.scm +++ b/scheme/httpd/surflets/packages.scm @@ -158,6 +158,9 @@ make-image-button input-field-value input-field-binding + + make-address + returned-via? make-callback)) (define-structure servlets servlets-interface diff --git a/scheme/httpd/surflets/surflets.scm b/scheme/httpd/surflets/surflets.scm index 96b71b4..e3b011d 100644 --- a/scheme/httpd/surflets/surflets.scm +++ b/scheme/httpd/surflets/surflets.scm @@ -149,12 +149,18 @@ maybe-text URI)"")))) +(define plain-html-rule + `(plain-html + *preorder* + . ,(lambda (tag . text) text))) + (define default-rules `(,attribute-rule (*default* . ,(lambda (tag . elems) (apply (entag tag) elems))) ,text-rule - ,URL-rule)) + ,URL-rule + ,plain-html-rule)) (define (make-callback function) (call-with-current-continuation @@ -214,11 +220,12 @@ (input-field-name input-field)))) ;; FIXME: consider creating small names -(define generate-input-field-name +(define generate-unique-name (let ((id 0)) (lambda (type-string) (set! id (+ 1 id)) (string-append type-string (number->string id))))) +(define generate-input-field-name generate-unique-name) (define identity (lambda (a) a)) @@ -486,4 +493,30 @@ (assoc (input-field-name input-field) bindings)) (define (input-field-binding input-field bindings) - (real-input-field-binding (cadr input-field) bindings)) \ No newline at end of file + (real-input-field-binding (cadr input-field) bindings)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; return address + +;; generates an unique return-addres +;; may be used like +;; (let ((address (make-address))) +;; (send-html/suspend +;; (lambda (new-url) +;; ... +;; (URL (address new-url) "Click here to get more")...) +(define (make-address) + (let ((name (generate-unique-name "return"))) + (lambda (message) + (cond + ((string? message) + (string-append message "?" name "=")) + ((eq? message 'name) + name) + (else ;maybe we want more later... + (error "unknown message" message name)))))) + + +(define (returned-via? return-address bindings) + (assoc (return-address 'name) bindings)) +