first shot on servlet's new form interface

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))

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
+	(servlet-XML->HTML out (html-tree-maker new-url)))))))
-	 out
-	 (lambda () (SXML->HTML (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)
+(define (do-sending send html-tree)
-  (sending-version
+  (send (make-usual-html-response
-   (make-usual-html-response
+	 (lambda (out options)
-    (lambda (out options)
+	   (servlet-XML->HTML out html-tree)))))
-      (with-current-output-port*		; FIXME: will change in further revision
-       out
-       (lambda () (SXML->HTML 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))))))
 

scheme/httpd/surflets/web-server/root/surflets/add2.scm

@@ -6,41 +6,27 @@
 	scheme)
   (begin
 
-    (define (add-call-back continue)
+    (define number-input-field (make-number-input-field '(maxlength 10)))
-      (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 (get-number input-text . maybe-title)
       (let* ((title (if (pair? maybe-title) (car maybe-title) #f))
-	     (result (call-with-current-continuation
+	     (result 
-		      (lambda (exit)
+	      (send-html/suspend
-			(send-html
+	       (lambda (new-url)
-			 (lambda (new-url)
+		 `(html ,(if title
-			   `(html ,(if title
+			     `(title ,title) '())
-				       `(title ,title) '())
+			(body
-				  (body
+			 ,(if title `(h1 ,title) '())
-				   ,(if title `(h1 ,title) '())
+			 (p (a (@ href "reset") 
-				   (p (a (@ href "reset") "click here to reset server's plugin cache"))
+			       "click here to reset server's plugin cache"))
-				   (p
+			 (p
-				    (form (@ (method "get")
+			  (form ,new-url
-					     (action ,(add-call-back exit)))
+				,input-text
-					  ,input-text
+				,number-input-field
-					  (input (@ (type "text")
+				,(make-submit-button)))))))))
-						    (name "number"))
-						 (input (@ (type "submit"))))))))))))))
 	(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"))
     ))
 	 

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)
+    (define (main req)
-      (make-response
+      (send-html/finish
-       http-status/ok
+       '(html (body (h1 "This is from servlet")))))))
-       (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>~%")))))))
-