renaming UTILTIES.SCM to SERVLETS.SCM and structure PLUGIN-UTILITIES to SERVLETS

scheme/httpd/surflets/packages.scm

@@ -99,7 +99,7 @@
   (files servlet-handler))
 
 
-(define-interface plugin-utilities-interface
+(define-interface servlets-interface
   (export send/suspend
 	  send/finish
 	  send-html/suspend
@@ -118,7 +118,7 @@
 	  input-field-value
 	  make-callback))
   
-(define-structure plugin-utilities plugin-utilities-interface
+(define-structure servlets servlets-interface
   (open servlet-handler/plugin
 	httpd-responses
 	parse-html-forms
@@ -130,7 +130,7 @@
 	define-record-types
 	scsh
 	scheme)
-  (files utilities))
+  (files servlets))
 
 (define-interface plugin-interface
   (export main))			; MAIN gets one parameter, the REQUEST

scheme/httpd/surflets/surflets.scm

@@ -0,0 +1,258 @@
+;; utilities for plugin (servlets)
+;; Copyright 2002, Andreas Bernauer
+
+(define (send-html/suspend html-tree-maker)
+  (send/suspend 
+   (lambda (new-url)
+     (make-usual-html-response
+      (lambda (out options)
+	(servlet-XML->HTML out (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
+	 (lambda (out options)
+	   (servlet-XML->HTML out html-tree)))))
+
+(define (make-usual-html-response writer-proc)
+  (make-response
+   http-status/ok
+   (status-code->text http-status/ok)
+   (time)
+   "text/html"
+   '()
+   (make-writer-body writer-proc)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 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 only works for GET and POST methods.
+
+(define form-query parse-html-form-query)
+
+(define (extract-bindings bindings key)
+  (let ((key (if (symbol? key) (symbol->string key) key)))
+    (filter (lambda (binding) 
+	      (equal? (car binding) key))
+	    bindings)))
+
+(define (extract-single-binding bindings key)
+  (let ((key-bindings (extract-bindings bindings key)))
+    (if (= 1 (length key-bindings))
+	(cdar 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)
+  (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/add.scm

@@ -1,5 +1,5 @@
 (define-structure plugin plugin-interface
-  (open plugin-utilities
+  (open servlets
 	httpd-request
 	url
 	scsh

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

@@ -1,5 +1,5 @@
 (define-structure plugin plugin-interface
-  (open plugin-utilities
+  (open servlets
 	httpd-request
 	url
 	scsh

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

@@ -1,7 +1,7 @@
 (define-structure plugin plugin-interface
   (open scsh
 	scheme
-	plugin-utilities
+	servlets
 	crlf-io)
   (begin
     (define *data* '())

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

@@ -1,7 +1,7 @@
 (define-structure plugin plugin-interface
   (open scsh
 	scheme
-	plugin-utilities
+	servlets
 	httpd-responses)
   (begin
     (define (main req)