From 3fc36e865e431239470228db59e9a3f67a04e8ff Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Mon, 10 Mar 2003 16:29:32 +0000
Subject: [PATCH] + Splitting file surflets.scm into several packages -
 Removing surflets.scm + The surflets package remains and collects the most
 usual used packages   It does not export any more the outdaters, the access
 to IDs     (like session-id), callbacks, form-query-list.       (and maybe
 some other stuff I've forgot to mention here, see list below).

The new packages are (not included in surflets are marked (*)):
+ surflets/addresses: MAKE-ADDRESS, MAKE-ANNOTATED-ADDRESS
+ surflets/bindings: GET-BINDINGS, EXTRACT-BINDINGS and stuff
+ surflets/ids (*): MY-SESSION-ID, .., INSTANCE-SESSION-ID
+ surflets/input-fields: MAKE-INPUT-FIELD, MAKE-NUMBER-INPUT-FIELD...
+ surflets/outdaters(*): MAKE-OUTDATER, OUTDATER?...
+ surflets/returned-via: RETURNED-VIA, CASE-RETURNED-VIA
+ surflets/send-html: SEND-HTML/SUSPEND...
+ surflets/surflet-sxml: URL-RULE,..., SURLFET-SXML-RULES, ...
+ surflets/sxml: SXML->STRING, DEFAULT-RULE,...
+ surflets/typed-optionals(*): TYPED-OPTIONALS, OPTIONALS
+ surflets/utilities(*): MAKE-CALLBACK, FORM-QUERY-LIST,
                         GENERATE-UNIQUE-NAME...
---
 scheme/httpd/surflets/addresses.scm           |  48 ++
 scheme/httpd/surflets/bindings.scm            |  89 +++
 scheme/httpd/surflets/ids.scm                 |  19 +
 scheme/httpd/surflets/input-fields.scm        | 281 +++++++
 scheme/httpd/surflets/outdater.scm            |  33 +
 scheme/httpd/surflets/packages.scm            | 311 ++++++--
 scheme/httpd/surflets/returned-via.scm        |  47 ++
 scheme/httpd/surflets/send-html.scm           |  30 +
 scheme/httpd/surflets/surflet-sxml.scm        |  83 ++
 scheme/httpd/surflets/surflets.scm            | 748 ------------------
 scheme/httpd/surflets/sxml.scm                |  66 ++
 scheme/httpd/surflets/typed-optionals.scm     |  64 ++
 scheme/httpd/surflets/utilities.scm           |  35 +
 .../web-server/root/surflets/add-html.scm     |   1 +
 .../root/surflets/admin-surflets-cb.scm       |   2 +
 .../root/surflets/admin-surflets.scm          |   3 +
 .../web-server/root/surflets/calculate-cb.scm |   1 +
 17 files changed, 1034 insertions(+), 827 deletions(-)
 create mode 100644 scheme/httpd/surflets/addresses.scm
 create mode 100644 scheme/httpd/surflets/bindings.scm
 create mode 100644 scheme/httpd/surflets/ids.scm
 create mode 100644 scheme/httpd/surflets/input-fields.scm
 create mode 100644 scheme/httpd/surflets/outdater.scm
 create mode 100644 scheme/httpd/surflets/returned-via.scm
 create mode 100644 scheme/httpd/surflets/send-html.scm
 create mode 100644 scheme/httpd/surflets/surflet-sxml.scm
 delete mode 100644 scheme/httpd/surflets/surflets.scm
 create mode 100644 scheme/httpd/surflets/sxml.scm
 create mode 100644 scheme/httpd/surflets/typed-optionals.scm
 create mode 100644 scheme/httpd/surflets/utilities.scm

diff --git a/scheme/httpd/surflets/addresses.scm b/scheme/httpd/surflets/addresses.scm
new file mode 100644
index 0000000..331d726
--- /dev/null
+++ b/scheme/httpd/surflets/addresses.scm
@@ -0,0 +1,48 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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-record-type address :address
+  (really-make-address name annotated?)
+  (name real-address-name)
+  (annotated? real-address-annotated?))
+
+(define (make-address)
+  (let ((address (really-make-address
+		  (generate-unique-name "return") #f)))
+    (lambda (message)
+      (cond
+       ((string? message)
+	(string-append message "?" (real-address-name address) "="))
+       ((eq? message 'address)
+	address)
+       (else
+	(error "address: unknown message/bad argument" 
+	       message (real-address-name address)))))))
+
+(define (make-annotated-address)
+  (let ((address (really-make-address 
+		  (generate-unique-name "return")
+		  #t)))
+    (lambda (message . annotation)
+      (cond
+       ((and (string? message)
+	     (<= (length annotation) 1))
+	(let ((escaped-annotation 
+	       (if (null? annotation)
+		   ""
+		   (escape-uri (car annotation)))))
+	  (string-append message "?" (real-address-name address)
+			 "=" escaped-annotation)))
+       ((eq? message 'address)
+	address)
+       (else
+	(error "annotated-address: unknown message/bad argument(s)" 
+	       message (real-address-name address)))))))
diff --git a/scheme/httpd/surflets/bindings.scm b/scheme/httpd/surflets/bindings.scm
new file mode 100644
index 0000000..6965808
--- /dev/null
+++ b/scheme/httpd/surflets/bindings.scm
@@ -0,0 +1,89 @@
+;; Copyright 2002, 2003 Andreas Bernauer
+
+;; Bindings of POST requests can be read only once, since they are
+;; read from an input port. So we have to cache them, for the case of
+;; a later GET-BINDINGS call on the same POST request. The requests
+;; are referenced by a weak pointer. Thread-safe as all threads use
+;; the same lock.
+(define *POST-bindings-cache* '())
+(define *cache-lock* (make-lock))
+
+(define (get-bindings surflet-request)
+  (let ((request-method (surflet-request-method surflet-request)))
+    (cond
+     ((string=? request-method "GET")
+      (form-query-list (http-url-search 
+			(surflet-request-url surflet-request))))
+     ((string=? request-method "POST")
+      (or (cached-bindings surflet-request)
+	  (let* ((content-length (get-content-length 
+				  (surflet-request-headers surflet-request)))
+		 (input-port (surflet-request-input-port surflet-request))
+		 (form-data (read-string content-length input-port)))
+	    (let ((form-bindings (form-query-list form-data)))
+	      (obtain-lock *cache-lock*)
+	      (set! *POST-bindings-cache* (cons (cons (make-weak-pointer surflet-request)
+						      form-bindings)
+						*POST-bindings-cache*))
+	      (release-lock *cache-lock*)
+	      form-bindings))))
+     (else
+      (error "unsupported request type")))))
+
+;; Looking up, if we have cached this request. While going through the
+;; list, we remove entries to request objects, that are no longer
+;; valid. Expecting a call for an uncached request every now and then,
+;; it is guaranteed, that the list is cleaned up every now and
+;; then. The cache is a list of pairs
+;;; (surflet-request . computed-binding)
+(define (cached-bindings surflet-request)
+  (obtain-lock *cache-lock*)
+  (let ((result 
+	 (let loop ((cache *POST-bindings-cache*))
+	   (if (null? cache)
+	       #f			; no such request cached
+	       (let* ((head (car cache))
+		      (s-req (weak-pointer-ref (car head))))
+		 (if s-req
+		     (if (eq? s-req surflet-request)
+			 (cdar cache)	; request is cached
+			 (loop (cdr cache))) ; request isn't cached
+		     (begin
+		       ;; request object is gone ==> remove it from list
+		       (set! cache (cdr cache))
+		       (loop cache))))))))
+    (release-lock *cache-lock*)
+    result))
+
+   
+;; Will be needed when we handle POST requests.
+(define (get-content-length headers)
+  (cond ((get-header headers 'content-length) =>
+	 ;; adopted from httpd/cgi-server.scm
+	 (lambda (content-length)	; Skip initial whitespace (& other non-digits).
+	   (let ((first-digit (string-index content-length char-set:digit))
+		 (content-length-len (string-length content-length)))
+	     (if first-digit
+		 (string->number (substring content-length first-digit 
+					    content-length-len))
+		 ;; (status-code bad-request) req 
+		 (error "Illegal `Content-length:' header.")))))
+	(else 
+	 (error "No Content-length specified for POST data."))))
+
+(define (extract-bindings key bindings)
+  (let ((key (if (symbol? key) (symbol->string key) key)))
+    (map cdr
+	 (filter (lambda (binding) 
+		   (equal? (car binding) key))
+		 bindings))))
+
+(define (extract-single-binding key bindings)
+  (let ((key-bindings (extract-bindings key bindings)))
+    (if (= 1 (length key-bindings))
+	(car key-bindings)
+	(error "extract-one-binding: more than one or zero bindings found"
+	       (length key-bindings)
+	       key bindings))))
+
+
diff --git a/scheme/httpd/surflets/ids.scm b/scheme/httpd/surflets/ids.scm
new file mode 100644
index 0000000..66aa081
--- /dev/null
+++ b/scheme/httpd/surflets/ids.scm
@@ -0,0 +1,19 @@
+(define (surflet-file-name req)
+  (last (http-url-path (surflet-request-url req))))
+
+;; This works for all requests except for the initial one. For the
+;; initial one (main's arg) think about using instance-session-id.
+(define (my-session-id req)
+  (resume-url-session-id (surflet-file-name req)))
+
+;;  This works for all requests except for the initial one: we don't
+;;  have a continuation at this time.
+(define (my-continuation-id req)
+  (resume-url-continuation-id (surflet-file-name req)))
+
+;; Returns two values: session-id and continuation-id. The
+;; restrictions from my-session-id and my-continuation-id apply here
+;; as well.
+(define (my-ids req)
+  (resume-url-ids (surflet-file-name req)))
+
diff --git a/scheme/httpd/surflets/input-fields.scm b/scheme/httpd/surflets/input-fields.scm
new file mode 100644
index 0000000..3010f53
--- /dev/null
+++ b/scheme/httpd/surflets/input-fields.scm
@@ -0,0 +1,281 @@
+;;; Copyright 2002, 2003 Andreas Bernauer
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; input-fields
+;;; defines input-fields for surflets
+
+(define *input-field-trigger* `*input-field*)
+
+;; GET-BINDINGS?: Transformer will get all bindings of request, not
+;; only the one concerning the input-field.
+(define-record-type input-field :input-field
+  (real-make-input-field name transformer html-tree get-bindings?)
+  real-input-field?
+  (name input-field-name)
+  (transformer input-field-transformer)
+  (attributes input-field-attributes)
+  (html-tree input-field-html-tree)
+  (get-bindings? input-field-get-bindings?))
+
+(define-record-discloser :input-field
+  (lambda (input-field)
+    (list 'input-field
+	  (input-field-name input-field))))
+
+;; Have to do a trick to get around with SSAX: input-field is a list
+;; whose first element is *input-field-trigger* and the last (next) one
+;; is a real input-field.
+(define (input-field? input-field)
+  (and (pair? input-field)
+       (eq? *input-field-trigger* (car input-field))
+       (real-input-field? (cadr input-field))))
+
+;; FIXME: consider creating small names
+(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))
+
+;; See note at input-field? for reasons for the list.
+(define (make-input-field name transformer html-tree)
+  (list *input-field-trigger* 
+	(real-make-input-field name transformer html-tree #f)))
+
+(define (make-higher-input-field transformer html-tree)
+  (list *input-field-trigger* 
+	(real-make-input-field #f transformer html-tree #t)))
+
+(define (make-text-input-field . maybe-further-attributes)
+  (let ((name (generate-input-field-name "text")))
+    (optionals maybe-further-attributes 
+	((default-text string?)
+	 (attributes sxml-attribute?))
+      (make-input-field name
+			identity
+			`(input (@ (type "text")
+				   (name ,name)
+				   ,(and default-text `(value ,default-text))
+				   ;; this will insert a list, but
+				   ;; XML->HTML doesn't care about it
+				   ,(and attributes (cdr attributes))
+				   ))))))
+
+(define make-number-input-field
+  (let ((number-input-field-transformer
+	 (lambda (string)
+	   (or (string->number string)
+	       (error "wrong type")))
+	 ))
+    (lambda maybe-further-attributes
+      (let ((name (generate-input-field-name "number")))
+	(optionals maybe-further-attributes
+	    ((default (lambda (a) (or (number? a)
+				      (string-or-symbol? a))))
+	     (attributes sxml-attribute?))
+	  (make-input-field
+	   name
+	   number-input-field-transformer
+	   `(input (@ (type "text")
+		      (name ,name)
+		      ,(and default `(value ,default))
+		      ,(and attributes (cdr attributes))))))))))
+
+(define (make-password-input-field . maybe-further-attributes)
+  (let ((name (generate-input-field-name "password")))
+    (optionals maybe-further-attributes
+	((attributes sxml-attribute?))
+      (make-input-field 
+       name
+       identity
+       `(input (@ (type "password")
+		  (name ,name)
+		  ,(and attributes (cdr attributes))))))))
+
+(define (make-textarea-input-field .  maybe-further-attributes)
+  (let ((name (generate-input-field-name "textarea")))
+    (optionals maybe-further-attributes
+	((default-text string?)
+	 (attributes sxml-attribute?))
+      (make-input-field 
+       name
+       identity
+       `(textarea (@ (type "textarea")
+		     (name ,name)
+		     ,(and attributes (cdr attributes)))
+		  ,(and default-text))))))
+
+;(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-field 
+  (let ((make-multiple-transformer
+	 (lambda (name)
+	   (lambda (bindings)
+	     (map cdr
+		  (filter (lambda (binding)
+			    (equal? (car binding) name))
+			  bindings))))))
+
+    (lambda (options . maybe-further-attributes)
+      (optionals maybe-further-attributes
+	    ((multiple? boolean?)
+	     (attributes sxml-attribute?))
+	(let* ((name (generate-input-field-name "select"))
+	       (sxml-options 
+		(map (lambda (option)
+		       (cond
+			((string-or-symbol? option) 
+			 (list 'option option))
+			((list? option) 
+			 (cond
+			  ((null? (cdr option))
+			   `(option ,option))
+			  ((sxml-attribute? (cdr option)) ; w/attribs?
+			   `(option ,(cdr option) ,(car option)))
+			  (else
+			   (error "not an attribute" (cdr option)))))
+			(else
+			 (error "not an option" option))))
+		     options))
+	       (sxml `(select (@ ((name ,name)
+				 ,(if multiple? '(multiple) '())
+				 ,(and attributes (cdr attributes))))
+			     #\newline
+			     ,sxml-options)))
+	  (if multiple?
+	      (make-higher-input-field (make-multiple-transformer name) sxml)
+	      (make-input-field name identity sxml)))))))
+
+;; 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 sxml-attribute?))
+      (map (lambda (value)
+	     (let ((value-value (if (pair? value) (car value) value))
+		   (value-attributes (if (pair? value)
+					 (if (sxml-attribute? (cdr value))
+					     (cddr value)
+					     (error "not an attribute" cdr value))
+					 #f)))
+	       (make-input-field
+		name
+		(lambda (select)
+		  select)
+		`(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")))
+    (optionals maybe-further-attributes
+	((checked? boolean?)
+	 (value (lambda (a) (or (string? a) 
+				(number? a)
+				(symbol? a))))
+	 (attributes sxml-attribute?))
+      (make-input-field
+       name
+       (lambda (value)
+	 (or (string=? value "on")
+	     value))
+       `(input (@ ((type "checkbox")
+		   (name ,name)
+		   ,(if value `(value ,value) '())
+		   ,(if checked? '(checked) '())
+		   ,(and attributes (cdr attributes)))))))))
+			   
+
+(define (make-hidden-input-field value . maybe-further-attributes)
+  (let ((name (generate-input-field-name "hidden")))
+    (optionals maybe-further-attributes
+	((attributes sxml-attribute?))
+      (make-input-field name
+			identity
+			`(input (@ (type "hidden")
+				   (name ,name)
+				   (value ,value)
+				   ,(and attributes (cdr attributes))))))))
+
+(define (make-button type name button-caption attributes)
+  (make-input-field name
+		    identity
+		    `(input (@ (type ,type)
+			       (name ,name)
+			       ,(and button-caption `(value ,button-caption))
+			       ,(and attributes (cdr attributes))))))
+
+(define (string-or-symbol? a) 
+  (or (string? a)
+      (symbol? a)))
+
+(define (make-submit-button . maybe-further-attributes)
+  (optionals maybe-further-attributes
+      ((button-caption string-or-symbol?)
+       (attributes sxml-attribute?))
+    (make-button "submit" (generate-input-field-name "submit")
+		 button-caption attributes)))
+
+(define (make-reset-button . maybe-further-attributes)
+  (optionals maybe-further-attributes
+      ((button-caption string-or-symbol?)
+       (attributes sxml-attribute?))
+    (make-button "reset" (generate-input-field-name "reset")  
+		 button-caption attributes)))
+
+(define (make-image-button image-source . maybe-further-attributes)
+  (optionals maybe-further-attributes
+      ((attributes sxml-attribute?))
+    (make-button "image"  (generate-input-field-name "imgbtn")
+		 #f `(@ (src ,image-source) 
+			,@(if attributes (cdr attributes) '())))))
+
+;; <input-field>: '(input-field . <real-input-field>)
+;; <real-input-field>: #{Input-field "name"}
+(define (raw-input-field-value input-field bindings)
+  (let ((input-field (cadr input-field)))
+    (cond
+     ((input-field-get-bindings? input-field)
+      ((input-field-transformer input-field) bindings))
+     ((real-input-field-binding input-field bindings) =>
+      (lambda (binding)
+	((input-field-transformer input-field) (cdr binding))))
+     (else
+      (error "no such input-field" input-field bindings)))))
+
+;; Trys to get a value for INPUT-FIELD in BINDINGS. If this fails
+;; (i.e. RAW-INPUT-FIELD-VALUE returns an error), the default-value is
+;; returned. The default-value defaults to #f. NOTE: If you do this
+;; with input-fields whose valid values may be the same as the default
+;; value, you cannot determine by the result if there was such a value
+;; or not. Keep in mind, that RAW-INPUT-FIELD-VALUE returns also an
+;; error, if there was not such an input field. This makes
+;; INPUT-FIELD-VALUE working with checkbox input fields because they
+;; miss if they are not checked.
+(define (input-field-value input-field bindings . maybe-default)
+  (let ((default (:optional maybe-default #f)))
+    (with-fatal-error-handler
+     (lambda (condition more)
+       default)
+     (raw-input-field-value input-field bindings))))
+
+(define (real-input-field-binding input-field bindings)
+  (assoc (input-field-name input-field) bindings))
+
+(define (input-field-binding input-field bindings)
+  (real-input-field-binding (cadr input-field) bindings))
+
diff --git a/scheme/httpd/surflets/outdater.scm b/scheme/httpd/surflets/outdater.scm
new file mode 100644
index 0000000..9b035b2
--- /dev/null
+++ b/scheme/httpd/surflets/outdater.scm
@@ -0,0 +1,33 @@
+;;; Copyright 2002, 2003 Andreas Bernauer
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; outdater
+
+(define-record-type outdater :outdater
+  (real-make-outdater outdated?)
+  outdater?
+  (outdated? outdater-outdated? set-outdater-outdated?!))
+
+(define (make-outdater)
+  (real-make-outdater #f))
+
+(define-syntax if-outdated
+  (syntax-rules ()
+    ((if-outdated outdater consequence alternative)
+     (if (outdater-outdated? outdater)
+	 consequence
+	 (begin
+	   (set-outdater-outdated?! outdater #t)
+	   alternative)))))
+
+(define (show-outdated url)
+  (send-html 
+   `(html (title "Outdated Data")
+	  (body (h1 "Outdated Data")
+		(p "The page or action you requested relies on outdated data.")
+		,(if url
+		     `(p "Try to " 
+			 (url ,url "reload") 
+			 " the page to get current data.")
+		     '())))))
diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm
index 750f064..8b37dcf 100644
--- a/scheme/httpd/surflets/packages.scm
+++ b/scheme/httpd/surflets/packages.scm
@@ -68,65 +68,6 @@
 	  resume-url-session-id
 	  resume-url-continuation-id))
 
-
-
-;; Helping functions for surflets
-(define-interface surflets-interface
-  (compound-interface
-   surflet-handler/surflets-interface
-  (export send-html/suspend
-	  send-html/finish
-	  send-html
-
-	  form-query-list
-	  get-bindings
-	  extract-bindings
-	  extract-single-binding
-
-	  adjust-timeout!
-
-	  make-outdater
-	  (if-outdated :syntax)
-	  show-outdated
-
-	  generate-input-field-name
-	  make-input-field
-	  make-higher-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-checkbox-input-field
-	  make-radio-input-fields
-
-	  make-submit-button
-	  make-reset-button
-	  make-image-button
-	  input-field-value
-	  raw-input-field-value
-	  input-field-binding
-
-	  make-address
-	  make-annotated-address
-
-	  returned-via
-	  returned-via?
-
-	  (case-returned-via :syntax)
-
-	  make-callback
-
-	  my-session-id
-	  my-continuation-id
-	  my-ids
-
-	  surflet-form-rules
-	  default-rules
-	  url-rule
-	  plain-html-rule)))
-
 ;; THE interface that SUrflets use.
 (define-interface surflet-interface
   (export main))			; MAIN gets one parameter, the REQUEST
@@ -229,8 +170,119 @@
 	  rt-structure-binding
 	  load-structure))
 
+;; With the help of TYPED-OPTIONALS you can define a function
+;; like (make-submit-button [string] args)
+(define-interface typed-optionals-interface
+  (export typed-optionals
+	  (optionals :syntax)))
 
-;;; Structures (GREP)
+;; Extensions/Exports to/from Olegs SSAX library
+(define-interface surflets/sxml-interface
+  (export display-low-level-sxml
+	  sxml->string
+	  sxml-attribute?
+	  default-rule
+	  text-rule
+	  attribute-rule))
+
+;; Input-fields as Scheme objects
+(define-interface surflets/input-fields-interface
+  (export generate-input-field-name
+	  make-input-field
+	  make-higher-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-checkbox-input-field
+	  make-radio-input-fields
+
+	  make-submit-button
+	  make-reset-button
+	  make-image-button
+	  input-field-value
+	  raw-input-field-value
+	  input-field-binding
+	  input-field?))
+
+;;; This is for surflets/surflet-sxml only:
+(define-interface surflets/input-fields/internal-interface
+  (export *input-field-trigger*
+	  input-field-html-tree))
+
+;; SUrflets' extensions to SXML
+(define-interface surflets/surflet-sxml-interface
+  (export surflet-sxml->low-level-sxml
+	  surflet-sxml-rules
+	  surflet-form-rule
+	  default-rules
+	  plain-html-rule
+	  url-rule))
+
+;; Access to session-id and continuation-id
+(define-interface surflets/ids-interface
+  (export my-session-id
+	  my-continuation-id
+	  my-ids
+	  instance-session-id))
+
+;; Some utilities
+(define-interface surflets/utilities-interface
+  (export form-query-list
+	  rev-append
+	  make-callback
+	  generate-unique-name))
+
+;; Intelligent Addresses
+(define-interface surflets/addresses-interface
+  (export make-address
+	  make-annotated-address
+	  real-address-name
+	  real-address-annotated?))
+
+;; Returned-via (dispatcher for input-fields and intelligent
+;; addresses)
+(define-interface surflets/returned-via-interface
+  (export returned-via
+	  returned-via?
+	  (case-returned-via :syntax)))
+
+;; Outdater denies access to outdated object
+(define-interface surflets/outdaters-interface
+  (export make-outdater
+	  (if-outdated :syntax)
+	  show-outdated))
+
+;; Access to form bindings in URL
+(define-interface surflets/bindings-interface
+  (export get-bindings
+	  get-content-length
+	  extract-bindings
+	  extract-single-binding))
+
+;; HTML-Extensions to send/suspend et al.
+(define-interface surflets/send-html-interface
+  (export send-html/suspend
+	  send-html/finish
+	  send-html))
+
+
+;; Helping functions for surflets
+(define-interface surflets-interface
+  (compound-interface
+   surflet-handler/surflets-interface
+   surflets/sxml-interface
+   surflets/surflet-sxml-interface
+   surflets/send-html-interface
+   surflets/input-fields-interface
+   surflets/addresses-interface
+   surflets/returned-via-interface
+   surflets/bindings-interface))
+
+
+;;; Structures
 ;; structures from SUrflet Handler
 (define-structures
   ((surflet-handler surflet-handler-interface)
@@ -267,25 +319,13 @@
 ;; SUrflets library of helping functions 
 (define-structure surflets surflets-interface
   (open surflet-handler/surflets
-	surflet-handler/responses
-	surflet-handler/admin
-	httpd-responses			; STATUS-CODE
-	surflet-requests		; HTTP-URL:SEARCH
-	url				; REQUEST:URL
-	(subset uri (escape-uri unescape-uri))
-	parse-html-forms
-	sxml-to-html			; SXML->HTML
-	srfi-1				; FILTER
-	(subset srfi-13 (string-index)) 
-	sxml-tree-trans
-	define-record-types
-	weak				;MAKE-WEAK-POINTER
-	locks
-	let-opt				;:OPTIONAL
-	handle-fatal-error
-	(subset sunet-utilities (get-header)) ; GET-HEADER
-	scheme-with-scsh)
-  (files surflets))
+	surflets/sxml
+	surflets/surflet-sxml
+	surflets/send-html
+	surflets/input-fields
+	surflets/addresses
+	surflets/returned-via
+	surflets/bindings))
 
 ;; Shift-Reset
 (define-structure shift-reset shift-reset-interface
@@ -337,6 +377,118 @@
 	httpd-requests)
   (files surflet-request))
 
+;; With the help of TYPED-OPTIONALS you can define a function
+;; like (make-submit-button [string] args)
+(define-structure typed-optionals typed-optionals-interface
+  (open scheme
+	receiving			;receive
+	srfi-23				;error
+	surflets/utilities		;rev-append
+	(subset srfi-1 (make-list)))
+  (files typed-optionals))
+
+;; Extensions to Olegs SSAX library
+(define-structure surflets/sxml surflets/sxml-interface
+  (open scheme-with-scsh		;string-ports
+	(subset sxml-to-html (string->goodHTML entag))
+	(subset sxml-tree-trans (pre-post-order)))
+  (files sxml))
+
+
+;; Input fields as Scheme objects
+(define-structures
+  ((surflets/input-fields surflets/input-fields-interface)
+   (surflets/input-fields/internal 
+    surflets/input-fields/internal-interface))
+  (open scheme
+	srfi-23				;error
+	(subset srfi-1 (filter))
+	(subset let-opt (:optional))
+	handle-fatal-error
+	define-record-types
+	(subset typed-optionals (optionals))
+	surflets/sxml
+	surflets/utilities		;rev-append,generate-unique-name
+	)
+  (files input-fields))
+
+
+;; Extensions to SXML for surflets
+(define-structure surflets/surflet-sxml surflets/surflet-sxml-interface
+  (open scheme-with-scsh		;error,receive
+	surflets/input-fields/internal
+	surflets/sxml
+	typed-optionals
+	(subset sxml-tree-trans (pre-post-order)))
+  (files surflet-sxml))
+
+
+;; Access to session-id and continuation-id
+(define-structure surflets/ids surflets/ids-interface
+  (open scheme
+	(subset surflet-requests (surflet-request-url))
+	(subset srfi-1 (last))
+	(subset surflet-handler/admin 
+		(instance-session-id
+		 resume-url-session-id
+		 resume-url-continuation-id
+		 resume-url-ids))
+	(subset url (http-url-path)))
+  (files ids))
+
+
+;; Some utilities
+(define-structure surflets/utilities surflets/utilities-interface
+  (open scheme
+	parse-html-forms
+	(subset surflet-handler/surflets (send/suspend)))
+  (files utilities))
+
+
+;; Intelligent Addresses 
+(define-structure surflets/addresses surflets/addresses-interface
+  (open scheme
+	srfi-23				;error
+	(subset uri (escape-uri))
+	define-record-types
+	(subset surflets/utilities (generate-unique-name)))
+  (files addresses))
+
+
+(define-structure surflets/returned-via surflets/returned-via-interface
+  (open scheme
+	surflets/input-fields
+	surflets/addresses
+	(subset uri (unescape-uri)))
+  (files returned-via))
+
+(define-structure surflets/outdaters surflets/outdaters-interface
+  (open scheme
+	define-record-types
+	surflets/send-html)
+  (files outdater))
+
+(define-structure surflets/bindings surflets/bindings-interface
+  (open scheme-with-scsh		;read-string,error
+	locks
+	weak				;weak pointers
+	surflets/utilities		;form-query-list
+	surflet-requests
+	(subset url (http-url-search))
+	(subset srfi-14 (char-set:digit))
+	(subset srfi-13 (string-index))
+	(subset srfi-1 (filter))
+	(subset sunet-utilities (get-header)))
+  (files bindings))
+
+(define-structure surflets/send-html surflets/send-html-interface
+  (open scheme
+	(subset httpd-responses (status-code))
+	surflet-handler/surflets
+	surflets/sxml
+	surflets/surflet-sxml)
+  (files send-html))
+
 ;; These two are from Martin Gasbichler:
 (define-structure rt-module-language rt-module-language-interface
   (open scheme
@@ -383,3 +535,4 @@
 	ensures-loaded
 	package-commands-internal)
   (files rt-module))
+
diff --git a/scheme/httpd/surflets/returned-via.scm b/scheme/httpd/surflets/returned-via.scm
new file mode 100644
index 0000000..c291883
--- /dev/null
+++ b/scheme/httpd/surflets/returned-via.scm
@@ -0,0 +1,47 @@
+
+(define (returned-via return-object bindings)
+  (if (input-field? return-object)
+      (input-field-binding return-object bindings)
+      ;; We assume we have a return-address-object instead.
+      (let ((address (return-object 'address)))
+	(cond 
+	 ((assoc (real-address-name address) bindings) =>
+	  (lambda (pair)
+	    (if (real-address-annotated? address)
+		(unescape-uri (cdr pair))
+		#t)))
+	 (else #f)))))
+
+;; It depends on the object, if returned-via returns only boolean
+;; values or string values as well. So let us have both names.
+(define returned-via? returned-via)
+
+;; This is from Martin Gasbichler
+(define-syntax case-returned-via
+  (syntax-rules (else =>)
+    ((case-returned-via (%bindings ...) clauses ...)
+     (let ((bindings (%bindings ...)))
+       (case-returned-via bindings clauses ...)))
+    ((case-returned-via bindings (else body ...))
+     (begin body ...))
+    ((case-returned-via bindings
+                        ((%return-object ...) => %proc))
+     (cond ((or (returned-via %return-object bindings) ...)
+            => %proc)))
+    ((case-returned-via bindings
+                        ((%return-object ...) %body ...))
+     (if (or (returned-via? %return-object bindings) ...)
+         (begin %body ...)))
+    ((case-returned-via bindings
+                        ((%return-object ...) => %proc)
+                        %clause %clauses ...)
+     (cond ((or (returned-via %return-object bindings) ...)
+            => %proc)
+           (else
+            (case-returned-via bindings %clause %clauses ...))))
+    ((case-returned-via bindings
+                        ((%return-object ...) %body ...)
+                        %clause %clauses ...)
+     (if (or (returned-via? %return-object bindings) ...)
+         (begin %body ...) 
+         (case-returned-via bindings %clause %clauses ...)))))
\ No newline at end of file
diff --git a/scheme/httpd/surflets/send-html.scm b/scheme/httpd/surflets/send-html.scm
new file mode 100644
index 0000000..7526257
--- /dev/null
+++ b/scheme/httpd/surflets/send-html.scm
@@ -0,0 +1,30 @@
+;;; Allows sending of HTML represented in Oleg-like SXML-list instead
+;;; of pure string.
+;;; Copyright 2002,2003, Andreas Bernauer
+
+(define (send-html/suspend html-tree-maker)
+  (send/suspend 
+   (lambda (new-url)
+     (make-usual-html-response
+      (sxml->string (html-tree-maker new-url) 
+		    surflet-sxml-rules)))))
+
+(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 
+	 (sxml->string html-tree surflet-sxml-rules))))
+
+;; This is not for public, as we add the no-cache header that is
+;; needed for SUrflets.
+(define (make-usual-html-response html-string)
+  (make-surflet-response
+   (status-code ok)
+   "text/html"
+   '(("Cache-Control" . "no-cache"))
+   html-string))
+
diff --git a/scheme/httpd/surflets/surflet-sxml.scm b/scheme/httpd/surflets/surflet-sxml.scm
new file mode 100644
index 0000000..125f9ba
--- /dev/null
+++ b/scheme/httpd/surflets/surflet-sxml.scm
@@ -0,0 +1,83 @@
+(define url-rule
+  (cons 'url 
+	(lambda (tag uri . maybe-text) 
+	  (list "<a href=\"" uri "\">" 
+		(if (null? maybe-text)
+		    uri
+		    maybe-text)
+		"</a>"))))
+
+(define plain-html-rule
+  `(plain-html
+    *preorder*
+    . ,(lambda (tag . text) text)))
+
+(define default-rules
+ `(,attribute-rule
+   ,default-rule
+   ,text-rule
+   ,url-rule
+   ,plain-html-rule))
+
+(define surflet-form-rule
+  `(surflet-form 
+    ;; Must do something to prevent the k-url string to be HTML
+    ;; escaped.
+    *preorder*
+    . ,(lambda (trigger k-url . args)
+	 (receive (parameters elems)
+	     (typed-optionals (list symbol? sxml-attribute?) args)
+	   (make-surflet-form k-url ; k-url
+			      (car parameters) ; POST, GET or #f=GET
+			      (cadr parameters); attributes
+			      elems)))))
+
+(define (make-surflet-form k-url method attributes elems)
+  (let ((real-method (case method
+		       ((get GET) "GET")
+		       ((post POST) "POST")
+		       ((#f) "GET")
+		       (else
+			(error "invalid method type" method)))))
+    (surflet-sxml->low-level-sxml 
+     `(form (@ ((method ,real-method)
+		(action ,k-url)
+		,@(if attributes (cdr attributes) '())))
+	    ,@elems))))
+
+(define input-field-rule
+  `(,*input-field-trigger*
+    *preorder*
+    . ,(lambda (trigger input-field)
+	 (surflet-sxml->low-level-sxml
+	  (input-field-html-tree input-field)))))
+
+(define surflet-sxml-rules
+  `(,@default-rules
+     ;; form contents:
+     ,input-field-rule
+     ,surflet-form-rule))
+
+;; Low-Level-SXML is a list that can be understood by
+;; write-low-level-sxml. In contains only characters, strings, and
+;; thunks.
+(define (surflet-sxml->low-level-sxml sxml-tree)
+  (pre-post-order sxml-tree surflet-sxml-rules))
+
+;;; adapted from Oleg's SXML-to-HTML.scm
+;;; extended by additional port argument (see FORMATED-REPLY)
+;(define (surflet-xml->html port html-tree)
+;  (let ((fragments (reformat html-tree)))
+;  (cond 
+;   ((not port)
+;    (call-with-string-output-port
+;     (lambda (port)
+;       (formated-reply port fragments))))
+;   ((eq? port #t)
+;    (formated-reply (current-output-port) fragments))
+;   ((output-port? port)
+;    (formated-reply port fragments))
+;   (else
+;    (error "Invalid port argument to FORMATED-REPLY" port)))))
+
+  
\ No newline at end of file
diff --git a/scheme/httpd/surflets/surflets.scm b/scheme/httpd/surflets/surflets.scm
deleted file mode 100644
index d3f1c02..0000000
--- a/scheme/httpd/surflets/surflets.scm
+++ /dev/null
@@ -1,748 +0,0 @@
-;; utilities for surflet
-;; Copyright 2002,2003, Andreas Bernauer
-;; Copyright 2003, Martin Gasbichler
-
-(define (send-html/suspend html-tree-maker)
-  (send/suspend 
-   (lambda (new-url)
-     (make-usual-html-response
-      (surflet-xml->html #f (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 
-	 (surflet-xml->html #f html-tree))))
-
-(define (make-usual-html-response html-string)
-  (make-surflet-response
-   (status-code ok)
-   "text/html"
-   '(("Cache-Control" . "no-cache"))
-   html-string))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 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 works only for GET and POST methods.
-
-(define (form-query-list q)
-  (if q 
-      (parse-html-form-query q) 
-      '()))
-
-;; Bindings of POST requests can be read only once, since they are
-;; read from an input port. So we have to cache them, for the case of
-;; a later GET-BINDINGS call on the same POST request. The requests
-;; are referenced by a weak pointer. Thread-safe as all threads use
-;; the same lock.
-(define *POST-bindings-cache* '())
-(define *cache-lock* (make-lock))
-
-(define (get-bindings surflet-request)
-  (let ((request-method (surflet-request-method surflet-request)))
-    (cond
-     ((string=? request-method "GET")
-      (form-query-list (http-url-search 
-			(surflet-request-url surflet-request))))
-     ((string=? request-method "POST")
-      (or (cached-bindings surflet-request)
-	  (let* ((content-length (get-content-length 
-				  (surflet-request-headers surflet-request)))
-		 (input-port (surflet-request-input-port surflet-request))
-		 (form-data (read-string content-length input-port)))
-	    (let ((form-bindings (form-query-list form-data)))
-	      (obtain-lock *cache-lock*)
-	      (set! *POST-bindings-cache* (cons (cons (make-weak-pointer surflet-request)
-						      form-bindings)
-						*POST-bindings-cache*))
-	      (release-lock *cache-lock*)
-	      form-bindings))))
-     (else
-      (error "unsupported request type")))))
-
-;; Looking up, if we have cached this request. While going through the
-;; list, we remove entries to request objects, that are no longer
-;; valid. Expecting a call for an uncached request every now and then,
-;; it is guaranteed, that the list is cleaned up every now and
-;; then. The cache is a list of pairs
-;;; (surflet-request . computed-binding)
-(define (cached-bindings surflet-request)
-  (obtain-lock *cache-lock*)
-  (let ((result 
-	 (let loop ((cache *POST-bindings-cache*))
-	   (if (null? cache)
-	       #f			; no such request cached
-	       (let* ((head (car cache))
-		      (s-req (weak-pointer-ref (car head))))
-		 (if s-req
-		     (if (eq? s-req surflet-request)
-			 (cdar cache)	; request is cached
-			 (loop (cdr cache))) ; request isn't cached
-		     (begin
-		       ;; request object is gone ==> remove it from list
-		       (set! cache (cdr cache))
-		       (loop cache))))))))
-    (release-lock *cache-lock*)
-    result))
-
-   
-;; Will be needed when we handle POST requests.
-(define (get-content-length headers)
-  (cond ((get-header headers 'content-length) =>
-	 ;; adopted from httpd/cgi-server.scm
-	 (lambda (content-length)	; Skip initial whitespace (& other non-digits).
-	   (let ((first-digit (string-index content-length char-set:digit))
-		 (content-length-len (string-length content-length)))
-	     (if first-digit
-		 (string->number (substring content-length first-digit 
-					    content-length-len))
-		 ;; (status-code bad-request) req 
-		 (error "Illegal `Content-length:' header.")))))
-	(else 
-	 (error "No Content-length specified for POST data."))))
-
-(define (extract-bindings key bindings)
-  (let ((key (if (symbol? key) (symbol->string key) key)))
-    (map cdr
-	 (filter (lambda (binding) 
-		   (equal? (car binding) key))
-		 bindings))))
-
-(define (extract-single-binding key bindings)
-  (let ((key-bindings (extract-bindings key bindings)))
-    (if (= 1 (length key-bindings))
-	(car 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)
-  (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 (surflet-xml->html port html-tree)
-  (let ((fragments (reformat html-tree)))
-  (cond 
-   ((not port)
-    (call-with-string-output-port
-     (lambda (port)
-       (formated-reply port fragments))))
-   ((eq? port #t)
-    (formated-reply (current-output-port) fragments))
-   ((output-port? port)
-    (formated-reply port fragments))
-   (else
-    (error "In surflet-xml->html: invalid port argument to FORMATED-REPLY" 
-	   port)))))
-
-(define (reformat html-tree)
-  (pre-post-order 
-   html-tree
-   `(,@default-rules
-      ;; form contents:
-     ,@surflet-form-rules)))
-
-;; Used in input-fields as well
-(define *input-field-trigger* '*input-field*)
-
-(define surflet-form-rules
-  `((,*input-field-trigger*
-     *preorder*
-     . ,(lambda (trigger input-field)
-	  (reformat (input-field-html-tree input-field))))
-    
-    (surflet-form 
-     ;; Must do something to prevent the k-url string to be HTML
-     ;; escaped.
-     *preorder*
-     . ,(lambda (trigger k-url . args)
-	  (receive (parameters elems)
-	      (typed-optionals (list symbol? xml-attribute?) args)
-	    (make-surflet-form k-url ; k-url
-			       (car parameters) ; POST, GET or #f=GET
-			       (cadr parameters); attributes
-			       elems))))))
-
-(define (make-surflet-form k-url method attributes elems)
-  (let ((real-method (case method
-		       ((get GET) "GET")
-		       ((post POST) "POST")
-		       ((#f) "GET")
-		       (else
-			(error "invalid method type" method)))))
-    (reformat 
-     `(form (@ ((method ,real-method)
-		(action ,k-url)
-		,@(if attributes (cdr attributes) '())))
-	    ,@elems))))
-
-(define (xml-attribute? thing)
-  (and (pair? thing)
-       (eq? '@ (car thing))))
-
-(define attribute-rule
-  `(@		; local override for attributes
-    ((*default*       
-      . ,(lambda (attr-key . value) (enattr attr-key value))))
-    . ,(lambda (trigger . value) (list '@ value))))
-
-;; Create attribution-value pair for inside of tags
-;; If the attribute has no value, value must be '()
-(define (enattr attr-key attr-value)
-  (if (null? attr-value) 
-      (list #\space attr-key)
-      (list #\space attr-key "=\"" attr-value #\")))
-
-(define text-rule
-  `(*text*
-    . ,(lambda (trigger str) 
-	 (if (string? str) (string->goodHTML str) str))))
-
-(define url-rule
-  (cons 'url 
-	(lambda (tag uri . maybe-text) 
-	  (list "<a href=\"" uri "\">" 
-		(if (null? maybe-text)
-		    uri
-		    maybe-text)
-		"</a>"))))
-
-(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
-   ,plain-html-rule))
-
-(define (make-callback function)
-  (call-with-current-continuation
-   (lambda (exit)
-     (let* ((req (send/suspend (lambda (new-url)
-				 (exit new-url)))))
-       (function req)))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; outdater
-
-(define-record-type outdater :outdater
-  (real-make-outdater outdated?)
-  outdater?
-  (outdated? outdater-outdated? set-outdater-outdated?!))
-
-(define (make-outdater)
-  (real-make-outdater #f))
-
-(define-syntax if-outdated
-  (syntax-rules ()
-    ((if-outdated outdater consequence alternative)
-     (if (outdater-outdated? outdater)
-	 consequence
-	 (begin
-	   (set-outdater-outdated?! outdater #t)
-	   alternative)))))
-
-(define (show-outdated url)
-  (send-html 
-   `(html (title "Outdated Data")
-	  (body (h1 "Outdated Data")
-		(p "The page or action you requested relies on outdated data.")
-		,(if url
-		     `(p "Try to " 
-			 (url ,url "reload") 
-			 " the page to get current data.")
-		     '())))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; input-fields
-;;; defines input-fields for surflets
-
-;; get-bindings: Transformer will get all bindings of request, not
-;; only the one concerning the input-field.
-(define-record-type input-field :input-field
-  (real-make-input-field name transformer html-tree get-bindings?)
-  real-input-field?
-  (name input-field-name)
-  (transformer input-field-transformer)
-  (attributes input-field-attributes)
-  (html-tree input-field-html-tree)
-  (get-bindings? input-field-get-bindings?))
-
-(define-record-discloser :input-field
-  (lambda (input-field)
-    (list 'input-field
-	  (input-field-name input-field))))
-
-;; Have to do a trick to get around with SSAX: input-field is a list
-;; whose first element is *input-field-trigger* and the last (next) one
-;; is a real input-field.
-(define (input-field? input-field)
-  (and (pair? input-field)
-       (eq? *input-field-trigger* (car input-field))
-       (real-input-field? (cadr input-field))))
-
-;; FIXME: consider creating small names
-(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))
-
-;; See note at input-field? for reasons for the list.
-(define (make-input-field name transformer html-tree)
-  (list *input-field-trigger* 
-	(real-make-input-field name transformer html-tree #f)))
-
-(define (make-higher-input-field transformer html-tree)
-  (list *input-field-trigger* 
-	(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. TYPED-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 TYPED-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"
-			rest-args)
-	       (,%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 
-	((default-text string?)
-	 (attributes xml-attribute?))
-      (make-input-field name
-			identity
-			`(input (@ (type "text")
-				   (name ,name)
-				   ,(and default-text `(value ,default-text))
-				   ;; this will insert a list, but
-				   ;; XML->HTML doesn't care about it
-				   ,(and attributes (cdr attributes))
-				   ))))))
-
-(define make-number-input-field
-  (let ((number-input-field-transformer
-	 (lambda (string)
-	   (or (string->number string)
-	       (error "wrong type")))
-	 ))
-    (lambda maybe-further-attributes
-      (let ((name (generate-input-field-name "number")))
-	(optionals maybe-further-attributes
-	    ((default (lambda (a) (or (number? a)
-				      (string-or-symbol? a))))
-	     (attributes xml-attribute?))
-	  (make-input-field
-	   name
-	   number-input-field-transformer
-	   `(input (@ (type "text")
-		      (name ,name)
-		      ,(and default `(value ,default))
-		      ,(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)
-		  ,(and attributes (cdr attributes))))))))
-
-(define (make-textarea-input-field .  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)
-		     ,(and attributes (cdr attributes)))
-		  ,(and default-text))))))
-
-;(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-field 
-  (let ((make-multiple-transformer
-	 (lambda (name)
-	   (lambda (bindings)
-	     (map cdr
-		  (filter (lambda (binding)
-			    (equal? (car binding) name))
-			  bindings))))))
-
-    (lambda (options . maybe-further-attributes)
-      (optionals maybe-further-attributes
-	    ((multiple? boolean?)
-	     (attributes xml-attribute?))
-	(let* ((name (generate-input-field-name "select"))
-	       (sxml-options 
-		(map (lambda (option)
-		       (cond
-			((string-or-symbol? option) 
-			 (list 'option option))
-			((list? option) 
-			 (cond
-			  ((null? (cdr option))
-			   `(option ,option))
-			  ((xml-attribute? (cdr option)) ; w/attribs?
-			   `(option ,(cdr option) ,(car option)))
-			  (else
-			   (error "not an attribute" (cdr option)))))
-			(else
-			 (error "not an option" option))))
-		     options))
-	       (sxml `(select (@ ((name ,name)
-				 ,(if multiple? '(multiple) '())
-				 ,(and attributes (cdr attributes))))
-			     #\newline
-			     ,sxml-options)))
-	  (if multiple?
-	      (make-higher-input-field (make-multiple-transformer name) sxml)
-	      (make-input-field name identity sxml)))))))
-
-;; 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? (cdr value))
-					     (cddr value)
-					     (error "not an attribute" cdr value))
-					 #f)))
-	       (make-input-field
-		name
-		(lambda (select)
-		  select)
-		`(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")))
-    (optionals maybe-further-attributes
-	((checked? boolean?)
-	 (value (lambda (a) (or (string? a) 
-				(number? a)
-				(symbol? a))))
-	 (attributes xml-attribute?))
-      (make-input-field
-       name
-       (lambda (value)
-	 (or (string=? value "on")
-	     value))
-       `(input (@ ((type "checkbox")
-		   (name ,name)
-		   ,(if value `(value ,value) '())
-		   ,(if checked? '(checked) '())
-		   ,(and attributes (cdr attributes)))))))))
-			   
-
-(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)
-				   (value ,value)
-				   ,(and attributes (cdr attributes))))))))
-
-(define (make-button type name button-caption attributes)
-  (make-input-field name
-		    identity
-		    `(input (@ (type ,type)
-			       (name ,name)
-			       ,(and button-caption `(value ,button-caption))
-			       ,(and attributes (cdr attributes))))))
-
-(define (string-or-symbol? a) 
-  (or (string? a)
-      (symbol? a)))
-
-(define (make-submit-button . maybe-further-attributes)
-  (optionals maybe-further-attributes
-      ((button-caption string-or-symbol?)
-       (attributes xml-attribute?))
-    (make-button "submit" (generate-input-field-name "submit")
-		 button-caption attributes)))
-
-(define (make-reset-button . maybe-further-attributes)
-  (optionals maybe-further-attributes
-      ((button-caption string-or-symbol?)
-       (attributes xml-attribute?))
-    (make-button "reset" (generate-input-field-name "reset")  
-		 button-caption attributes)))
-
-(define (make-image-button image-source . maybe-further-attributes)
-  (optionals maybe-further-attributes
-      ((attributes xml-attribute?))
-    (make-button "image"  (generate-input-field-name "imgbtn")
-		 #f `(@ (src ,image-source) 
-			,@(if attributes (cdr attributes) '())))))
-
-;; <input-field>: '(input-field . <real-input-field>)
-;; <real-input-field>: #{Input-field "name"}
-(define (raw-input-field-value input-field bindings)
-  (let ((input-field (cadr input-field)))
-    (cond
-     ((input-field-get-bindings? input-field)
-      ((input-field-transformer input-field) bindings))
-     ((real-input-field-binding input-field bindings) =>
-      (lambda (binding)
-	((input-field-transformer input-field) (cdr binding))))
-     (else
-      (error "no such input-field" input-field bindings)))))
-
-;; Trys to get a value for INPUT-FIELD in BINDINGS. If this fails
-;; (i.e. RAW-INPUT-FIELD-VALUE returns an error), the default-value is
-;; returned. The default-value defaults to #f. NOTE: If you do this
-;; with input-fields whose valid values may be the same as the default
-;; value, you cannot determine by the result if there was such a value
-;; or not. Keep in mind, that RAW-INPUT-FIELD-VALUE returns also an
-;; error, if there was not such an input field. This makes
-;; INPUT-FIELD-VALUE working with checkbox input fields because they
-;; miss if they are not checked.
-(define (input-field-value input-field bindings . maybe-default)
-  (let ((default (:optional maybe-default #f)))
-    (with-fatal-error-handler
-     (lambda (condition more)
-       default)
-     (raw-input-field-value input-field bindings))))
-
-(define (real-input-field-binding input-field bindings)
-  (assoc (input-field-name input-field) bindings))
-
-(define (input-field-binding input-field bindings)
-  (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-record-type address :address
-  (really-make-address name annotated?)
-  (name address-name)
-  (annotated? address-annotated?))
-
-(define (make-address)
-  (let ((address (really-make-address
-		  (generate-unique-name "return") #f)))
-    (lambda (message)
-      (cond
-       ((string? message)
-	(string-append message "?" (address-name address) "="))
-       ((eq? message 'address)
-	address)
-       (else
-	(error "address: unknown message/bad argument" 
-	       message (address-name address)))))))
-
-(define (make-annotated-address)
-  (let ((address (really-make-address 
-		  (generate-unique-name "return")
-		  #t)))
-    (lambda (message . annotation)
-      (cond
-       ((and (string? message)
-	     (<= (length annotation) 1))
-	(let ((escaped-annotation 
-	       (if (null? annotation)
-		   ""
-		   (escape-uri (car annotation)))))
-	  (string-append message "?" (address-name address)
-			 "=" escaped-annotation)))
-       ((eq? message 'address)
-	address)
-       (else
-	(error "annotated-address: unknown message/bad argument(s)" 
-	       message (address-name address)))))))
-
-(define (returned-via return-object bindings)
-  (if (input-field? return-object)
-      (input-field-binding return-object bindings)
-      ;; We assume we have a return-address-object instead.
-      (let ((address (return-object 'address)))
-	(cond 
-	 ((assoc (address-name address) bindings) =>
-	  (lambda (pair)
-	    (if (address-annotated? address)
-		(unescape-uri (cdr pair))
-		#t)))
-	 (else #f)))))
-
-;; It depends on the object, if returned-via returns only boolean
-;; values or string values as well. So let us have both names.
-(define returned-via? returned-via)
-
-(define (surflet-file-name req)
-  (last (http-url-path (surflet-request-url req))))
-
-;; This works for all requests except for the initial one. For the
-;; initial one (main's arg) think about using instance-session-id.
-(define (my-session-id req)
-  (resume-url-session-id (surflet-file-name req)))
-
-;;  This works for all requests except for the initial one: we don't
-;;  have a continuation at this time.
-(define (my-continuation-id req)
-  (resume-url-continuation-id (surflet-file-name req)))
-
-;; Returns two values: session-id and continuation-id. The
-;; restrictions from my-session-id and my-continuation-id apply here
-;; as well.
-(define (my-ids req)
-  (resume-url-ids (surflet-file-name req)))
-
-;; This is from Martin Gasbichler
-(define-syntax case-returned-via
-  (syntax-rules (else =>)
-    ((case-returned-via (%bindings ...) clauses ...)
-     (let ((bindings (%bindings ...)))
-       (case-returned-via bindings clauses ...)))
-    ((case-returned-via bindings (else body ...))
-     (begin body ...))
-    ((case-returned-via bindings
-                        ((%return-object ...) => %proc))
-     (cond ((or (returned-via %return-object bindings) ...)
-            => %proc)))
-    ((case-returned-via bindings
-                        ((%return-object ...) %body ...))
-     (if (or (returned-via? %return-object bindings) ...)
-         (begin %body ...)))
-    ((case-returned-via bindings
-                        ((%return-object ...) => %proc)
-                        %clause %clauses ...)
-     (cond ((or (returned-via %return-object bindings) ...)
-            => %proc)
-           (else
-            (case-returned-via bindings %clause %clauses ...))))
-    ((case-returned-via bindings
-                        ((%return-object ...) %body ...)
-                        %clause %clauses ...)
-     (if (or (returned-via? %return-object bindings) ...)
-         (begin %body ...) 
-         (case-returned-via bindings %clause %clauses ...)))))
diff --git a/scheme/httpd/surflets/sxml.scm b/scheme/httpd/surflets/sxml.scm
new file mode 100644
index 0000000..0df8fc0
--- /dev/null
+++ b/scheme/httpd/surflets/sxml.scm
@@ -0,0 +1,66 @@
+;;; Copyright 2002, 2003 Andreas Bernauer
+
+;;; adapted from Oleg's SXML-tree-trans.scm SRV:send-reply
+;;; extended by port argument
+;;; #t: current-output-port
+;;; #f: string
+;;; port: port
+;;; else: error
+;; Displays low-level-sxml on the port. Low-level-sxml contains only
+;; strings, characters and thunks. '() and #f are ignored.
+(define (display-low-level-sxml fragments port)
+  (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)))))
+
+;; Gives you a string representing the HTML of the already reformatted
+;; SXML-TREE.
+(define (sxml->string sxml-tree rules)
+  (call-with-string-output-port
+   (lambda (port)
+     (display-low-level-sxml 
+      (pre-post-order sxml-tree rules) 
+      port))))
+
+;; Predicate for attributes in sxml.
+(define (sxml-attribute? thing)
+  (and (pair? thing)
+       (eq? '@ (car thing))))
+
+
+;; Default rule: Creates leading and trailing tag and encloses the
+;; attributes.
+(define default-rule
+  `(*default* 
+    . ,(lambda (tag . elems) (apply (entag tag) elems))))
+
+;; Just displays the string, except that some characters are escaped.
+(define text-rule
+  `(*text*
+    . ,(lambda (trigger str) 
+	 (if (string? str) (string->goodHTML str) str))))
+
+;; Rule for attribution: creates an attribute like "selected" or
+;; "color="red""
+(define attribute-rule
+  `(@		; local override for attributes
+    ((*default*       
+      . ,(lambda (attr-key . value) (enattr attr-key value))))
+    . ,(lambda (trigger . value) (list '@ value))))
+
+;; Create attribution-value pair for inside of tags
+;; If the attribute has no value, value must be '()
+(define (enattr attr-key attr-value)
+  (if (null? attr-value) 
+      (list #\space attr-key)
+      (list #\space attr-key "=\"" attr-value #\")))
diff --git a/scheme/httpd/surflets/typed-optionals.scm b/scheme/httpd/surflets/typed-optionals.scm
new file mode 100644
index 0000000..493a569
--- /dev/null
+++ b/scheme/httpd/surflets/typed-optionals.scm
@@ -0,0 +1,64 @@
+;; PRED-LIST contains list of predicates that recognizes optional
+;; leading parameters. FURTHER-ATTRIBUTES is the optional parameter
+;; list as got by procedure call. TYPED-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 TYPED-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"
+			rest-args)
+	       (,%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))))))
+
diff --git a/scheme/httpd/surflets/utilities.scm b/scheme/httpd/surflets/utilities.scm
new file mode 100644
index 0000000..755bdbd
--- /dev/null
+++ b/scheme/httpd/surflets/utilities.scm
@@ -0,0 +1,35 @@
+;; utilities for surflets
+;; Copyright 2002, 2003 Andreas Bernauer
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; from parse-html-forms (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 works only for GET and POST methods.
+
+(define (form-query-list q)
+  (if q 
+      (parse-html-form-query q) 
+      '()))
+
+;; 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-callback function)
+  (call-with-current-continuation
+   (lambda (exit)
+     (let* ((req (send/suspend (lambda (new-url)
+				 (exit new-url)))))
+       (function req)))))
+
+;; FIXME: consider creating small names
+(define generate-unique-name
+  (let ((id 0))
+    (lambda (type-string)
+      (set! id (+ 1 id))
+      (string-append type-string (number->string id)))))
\ No newline at end of file
diff --git a/scheme/httpd/surflets/web-server/root/surflets/add-html.scm b/scheme/httpd/surflets/web-server/root/surflets/add-html.scm
index 89f9102..a0fd046 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/add-html.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/add-html.scm
@@ -1,5 +1,6 @@
 (define-structure surflet surflet-interface
   (open surflets
+	surflets/utilities		;form-query-list
 	surflet-requests
 	httpd-responses
 	url
diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-surflets-cb.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-surflets-cb.scm
index 71f22fd..5bab20f 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/admin-surflets-cb.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/admin-surflets-cb.scm
@@ -1,6 +1,8 @@
 (define-structure surflet surflet-interface
   (open scheme-with-scsh
 	surflets
+	surflets/utilities		;make-callback
+	surflets/outdaters
 	surflet-handler/admin
 	httpd-responses
 	handle-fatal-error
diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm
index 83d56d9..18fbe7c 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm
@@ -1,6 +1,9 @@
 (define-structure surflet surflet-interface
   (open scheme-with-scsh
 	surflets
+	surflets/utilities		;make-callback
+	surflets/outdaters
+	surflets/ids
 	surflet-handler/admin
 	httpd-responses
 	surflet-requests
diff --git a/scheme/httpd/surflets/web-server/root/surflets/calculate-cb.scm b/scheme/httpd/surflets/web-server/root/surflets/calculate-cb.scm
index bba7dc5..3188f86 100644
--- a/scheme/httpd/surflets/web-server/root/surflets/calculate-cb.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/calculate-cb.scm
@@ -1,5 +1,6 @@
 (define-structure surflet surflet-interface
   (open surflets
+	surflets/utilities		;make-callback
 	surflet-requests
 	handle-fatal-error
 	let-opt