+ export conversion rules from surflets:

default-rules (default, text, attribute, plain-html and url) surflet-form-rules (input-field and surflet-form) + according to mainzelm: lowercase URL tag to url in surflet-xml
2003-03-09 20:15:08 +00:00 · 2003-03-09 20:15:08 +00:00 · 3b51f7b82b
parent 31f0044e2c
commit 3b51f7b82b
13 changed files with 109 additions and 76 deletions
--- a/scheme/httpd/surflets/packages.scm
+++ b/scheme/httpd/surflets/packages.scm
@ -120,7 +120,12 @@

 	  my-session-id
 	  my-continuation-id
-	  my-ids)))
+	  my-ids
+
+	  surflet-form-rules
+	  default-rules
+	  url-rule
+	  plain-html-rule)))

 ;; THE interface that SUrflets use.
 (define-interface surflet-interface
--- a/scheme/httpd/surflets/simple-surflet-api.scm
+++ b/scheme/httpd/surflets/simple-surflet-api.scm
@ -66,7 +66,7 @@
 	     (br)
 	     (p ,@text)
 	     (br)
-	     (URL ,url "Continue"))))))
+	     (url ,url "Continue"))))))

 ;; Post some information on a Web page, shut down the surflet and all
 ;; its continuations.
--- a/scheme/httpd/surflets/surflets.scm
+++ b/scheme/httpd/surflets/surflets.scm
@ -165,27 +165,30 @@
 (define (reformat html-tree)
  (pre-post-order 
   html-tree
-   `(
-     ;; Universal transformation rules. Works for every HTML,
-     ;; present and future
-     ,@default-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))))) ; form-content
-  ))
+   `(,@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
@ -223,11 +226,11 @@
 	 (if (string? str) (string->goodHTML str) str))))

 (define url-rule
-  (cons 'URL 
-	(lambda (tag URI . maybe-text) 
-	  (list "<a href=\"" URI "\">" 
+  (cons 'url 
+	(lambda (tag uri . maybe-text) 
+	  (list "<a href=\"" uri "\">" 
 		(if (null? maybe-text)
-		    URI
+		    uri
 		    maybe-text)
 		"</a>"))))

@ -279,7 +282,7 @@
 		(p "The page or action you requested relies on outdated data.")
 		,(if url
 		     `(p "Try to " 
-			 (URL ,url "reload") 
+			 (url ,url "reload") 
 			 " the page to get current data.")
 		     '())))))

@ -304,12 +307,11 @@
 	  (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
+;; whose first element is *input-field-trigger* and the last (next) one
 ;; is a real input-field.
-(define input-field-trigger '*input-field*)
 (define (input-field? input-field)
  (and (pair? input-field)
-       (eq? input-field-trigger (car input-field))
+       (eq? *input-field-trigger* (car input-field))
       (real-input-field? (cadr input-field))))

 ;; FIXME: consider creating small names
@ -324,10 +326,12 @@

 ;; 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)))
+  (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)))
+  (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
@ -637,7 +641,7 @@
 ;;   (send-html/suspend 
 ;;     (lambda (new-url)
 ;;       ...
-;;       (URL (address new-url) "Click here to get more")...)                
+;;       (url (address new-url) "Click here to get more")...)                

 (define-record-type address :address
  (really-make-address name annotated?)
--- a/scheme/httpd/surflets/web-server/root/surflets/add-html.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/add-html.scm
@ -23,8 +23,8 @@
 					  (name "number"))
 				       (input (@ (type "submit"))))))
 			 (hr)
-			 (p (URL "/" "Return to main menu") (br)
-			    (URL "add-html.scm" "Start new calculation."))))))))
+			 (p (url "/" "Return to main menu") (br)
+			    (url "add-html.scm" "Start new calculation."))))))))
 	(let* ((bindings (form-query-list
 			  (http-url-search (surflet-request-url result))))
 	       (number (string->number 
--- a/scheme/httpd/surflets/web-server/root/surflets/add-surflet.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/add-surflet.scm
@ -16,8 +16,8 @@
 			       ,number-input-field
 			       ,(make-submit-button)))
 		(hr)
-		(p (URL "/" "Return to main menu.") (br)
-		   (URL "add-surflet.scm" "Start new calculation."))))))
+		(p (url "/" "Return to main menu.") (br)
+		   (url "add-surflet.scm" "Start new calculation."))))))

    (define (get-number title input-text)
      (let* ((result (send-html/suspend
@ -40,10 +40,10 @@
 	      (body (h2 "Result")
 		    (p ,(+ (get-number-1) (get-number-2))
 		       (hr)
-		       (p (URL "add-surflet.scm" "Make new calculation.") (br)
-			  (URL "javascript:history.go(-2)" "New calculation (same session)")
+		       (p (url "add-surflet.scm" "Make new calculation.") (br)
+			  (url "javascript:history.go(-2)" "New calculation (same session)")
 			  (br)
-			  (URL "/" "Return to main menu."))))))
+			  (url "/" "Return to main menu."))))))

      "this string will never be evaluated")
    ))
--- a/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm
@ -31,8 +31,8 @@
 			      (td ,submit-button))))
 		     options)))
 	    (hr)
-	    (p (URL ,(return-address new-url) "Return to adminstration menu.") (br)
-	       (URL "/" "Return to main menu."))))
+	    (p (url ,(return-address new-url) "Return to adminstration menu.") (br)
+	       (url "/" "Return to main menu."))))
 	 )))
    
    (define submit-timeout (make-submit-button "Change"))
--- a/scheme/httpd/surflets/web-server/root/surflets/admin-surflets-cb.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/admin-surflets-cb.scm
@ -70,7 +70,7 @@

    (define (no-surflets)
      `(p "Currently, there are no SUrflets loaded " 
-	  (URL ,(make-callback surflets) "(reload).")))
+	  (url ,(make-callback surflets) "(reload).")))

    (define (surflets req . maybe-update-text)
      (let* ((update-text (:optional maybe-update-text ""))
@ -81,7 +81,7 @@
 		       (h2 "SUrflets")
 		       (p (font (@ (color "red")) ,update-text))))
 	     (footer `((hr)
-		       (URL ,(make-callback return-to-main-page) "Return to main page")))
+		       (url ,(make-callback return-to-main-page) "Return to main page")))
 	     (actions '("unload" "unload all" "view sessions")))
 	(if (null? loaded-surflets)
 	    (send-html `(html (title ,title) (body ,header ,(no-surflets) ,footer)))
@ -98,7 +98,7 @@
 			       `(p "Note that unloading the SUrflet does not imply "
 				   "the unloading of sessions of this SUrflet." 
 				   "This can be done on the " 
-				   (URL ,(make-callback sessions) 
+				   (url ,(make-callback sessions) 
 					"sessions adminstration page."))
 			       footer))
 	      (if (null? selected-surflets)
@ -147,7 +147,7 @@
      '(p "Currently, there are no sessions, "
 	  "i.e. the administration SUrflet is no longer running. "
 	  ;; Can't use callback here, as there are no valid sessions left.
-	  (URL "admin.scm" "Go back to main page.")))
+	  (url "admin.scm" "Go back to main page.")))

    (define (sessions req . maybe-update-text)
      (let* ((update-text (:optional maybe-update-text ""))
@ -161,7 +161,7 @@
 		       (h2 "Sessions")
 		       (p (font (@ (color "red")) ,update-text))))
 	     (footer `((hr)
-		       (URL ,(make-callback return-to-main-page) "Return to main page")))
+		       (url ,(make-callback return-to-main-page) "Return to main page")))
 	     (actions '("kill"
 			"adjust timeout" 
 			"view continuations"))
@ -210,11 +210,11 @@

    (define (no-current-continuations session)
      `((p "Currently, there are no continuations for this session. ")
-	(p "You may " (URL ,(make-callback 
+	(p "You may " (url ,(make-callback 
 			     (lambda (req) (continuations (list session))))
 			   "reload")
 	   " this page or go back to the "
-	   (URL ,(make-callback sessions) "session table overview."))))
+	   (url ,(make-callback sessions) "session table overview."))))

    (define (no-more-than-one-session title header1)
      (send-html 
@ -224,7 +224,7 @@
 		       "one session at a time. This will be changed in "
 		       "future revisions. Sorry for any inconvenience.")
 		    (p "You may choose to go back to the " 
-		       (URL ,(make-callback sessions) 
+		       (url ,(make-callback sessions) 
 			    "sessions administration page")
 		       " where you can choose one session.")))))
      
@ -252,11 +252,14 @@
 				    (p (font (@ (color "red")) ,update-text)))))
 		    (footer 
 		     `((hr)
-		       (URL ,(make-callback sessions) "Return to sessions page.") (br)
-		       (URL ,(make-callback return-to-main-page) "Return to main page.")))
+		       (url ,(make-callback sessions) 
+			    "Return to sessions page.") (br)
+		       (url ,(make-callback return-to-main-page)
+			    "Return to main page.")))
 		    (actions '("delete" "delete all"))
-		    (continuations-callback (make-callback (lambda (req)
-							     (continuations sessions)))))
+		    (continuations-callback 
+		     (make-callback (lambda (req)
+				      (continuations sessions)))))
 		(if (null? current-continuations)
 		    (send-html `(html (title ,title) 
 				      (body ,header 
--- a/scheme/httpd/surflets/web-server/root/surflets/admin.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/admin.scm
@ -12,11 +12,11 @@
 		   (p "Choose one of the following submenus:")
 		   (p
 		    (ul
-		     (li (URL "admin-handler.scm" "Set handler options..."))
-		     (li (URL "admin-surflets.scm" "SUrflets..."))
-		     (li (URL "admin-profiling.scm" "Profiling..."))))
+		     (li (url "admin-handler.scm" "Set handler options..."))
+		     (li (url "admin-surflets.scm" "SUrflets..."))
+		     (li (url "admin-profiling.scm" "Profiling..."))))
 		   (hr)
-		   (p (URL "/" "Return to main menu.")))))
+		   (p (url "/" "Return to main menu.")))))

    (define (main req)
      (send-html (main-page)))
--- a/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm
@ -40,8 +40,8 @@
 	       (h2 "Result")
 	       (p "You've entered " ,result ".")
 	       (hr)
-	       (p (URL "byte-input.scm" "Make new byte input.") (br)
-		  (URL "/" "Return to main menu."))))))
+	       (p (url "byte-input.scm" "Make new byte input.") (br)
+		  (url "/" "Return to main menu."))))))

    (define (get-byte-input)
      (let* ((req (send-html/suspend
@ -54,7 +54,7 @@
 					   ,byte-input-fields
 					   ,(make-submit-button))
 			     (hr)
-			     (p (URL "/" "Return to main menu.")))))))
+			     (p (url "/" "Return to main menu.")))))))
 	     (bindings (get-bindings req)))
 	(input-field-value byte-input-fields bindings)))

--- a/scheme/httpd/surflets/web-server/root/surflets/calculate.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/calculate.scm
@ -66,7 +66,7 @@
 			   (tr (td ,operator-input-field)
 			       (td ,change-button)))
 			  (hr)
-			  (p (URL "/" "Return to main menu."))))))))
+			  (p (url "/" "Return to main menu."))))))))
 	     (bindings (get-bindings req)))
 	(let ((number1 (input-field-value number-field1 bindings))
 	      (number2 (input-field-value number-field2 bindings)))
@ -105,8 +105,8 @@
 		    (p ,number1 " " ,operator-symbol " " ,number2
 		       " = " ,result)
 		    (hr)
-		    (p (URL "calculate.scm" "Make new calculation") (br)
-		       (URL "/" "Return to main menu."))))))
+		    (p (url "calculate.scm" "Make new calculation") (br)
+		       (url "/" "Return to main menu."))))))

    (define (main req)
      (show-page (car *operator-alist*) #f #f)
--- a/scheme/httpd/surflets/web-server/root/surflets/news.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/news.scm
@ -29,8 +29,8 @@
       `(html (body (p (h1 "THAT'S IT"))
 		    (p ("That's it..."))
 		    (hr)
-		    (p (URL "news.scm" "See news again.") (br)
-		       (URL "/" "Return to main menu."))))))
+		    (p (url "news.scm" "See news again.") (br)
+		       (url "/" "Return to main menu."))))))

    (define (show-news-page news)
      (send-html/suspend 
@ -38,7 +38,7 @@
 	 `(html (body (p (h1 ,news))
 		      (a (@ href ,next-url) "read more...")
 		      (hr)
-		      (p (URL "news.scm" "See news again from beginning.") (br)
-			 (URL "/" "Return to main menu.")))))))
+		      (p (url "news.scm" "See news again from beginning.") (br)
+			 (url "/" "Return to main menu.")))))))
    ))

--- a/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm
@ -469,13 +469,13 @@ spaceships of class " ,class ":")
 	       ,(return-links first-page-return-link main-return-link))))

 (define main-return-link
-  '(URL "/" "Return to main menu."))
+  '(url "/" "Return to main menu."))

 (define (previous-page-return-link prev)
-  `(URL ,prev "Return to previous page."))
+  `(url ,prev "Return to previous page."))

 (define first-page-return-link
-  '(URL "/surflet/spaceship.scm" "Return to spaceship builder entry page."))
+  '(url "/surflet/spaceship.scm" "Return to spaceship builder entry page."))

 (define (return-links . links)
  `(p
--- a/scheme/httpd/surflets/web-server/root/surflets/test.scm
+++ b/scheme/httpd/surflets/web-server/root/surflets/test.scm
@ -3,34 +3,54 @@
 	surflets
 	httpd-responses)
  (begin
+    (define global '())
+
    (define select (make-select-input-field '("a" "b" "c") #t '(@ (size 2))))

    (define (main req)
-      (let ((req (send-html/suspend
+      (set! global (cons 1 global))
+      (let* ((addr (make-annotated-address))
+	     (req (send-html/suspend
 		  (lambda (new-url)
 		    `(html (body (h1 "This is from SUrflet")
+				 (p "called " ,(length global) " times")
+				 (URL ,(addr new-url "ab=ba")) (br)
+				 (URL ,(addr new-url "be<ta")) (br)
+				 (URL ,(addr new-url)) (br)
+				 (abba)
 				 (surflet-form
 				  ,new-url
 				  POST
 				  ,select
+				  '(input (@ (type "text") (name "TeST")))
 				  ,(make-submit-button))
 				 (hr)
 				 (p (URL "/" "Return to main menu."))
 				 )))))
-	    (save-k #f)
-	    (done? #f))
+	     (save-k #f)
+	     (done? #f)
+	     (bindings (get-bindings req))
+	     (result
+	      (cond
+	       ((returned-via? addr bindings) =>
+		(lambda (string)
+		  (format #f "returned via annotated string ~s" string)))
+	       (else
+		(format #f "~s" bindings)))))
 	
 	(call-with-current-continuation
 	 (lambda (k)
 	   (set! save-k k)
 	   13))
 	
+	(set! global (cons 1 global))
 	(if (not done?)
 	    (begin
 	      (send-html/suspend
 	       (lambda (continue)
 		 `(html (body (h1 "Result")
-			      ,(format #f "~s" (get-bindings req)) (br)
+			      (p "called " ,(length global) " times")
+			      ,result (br)
 			      (URL ,continue "show results again")
 			      (hr)
 			      (p (URL "test.scm" "Test again.") (br)
@ -41,6 +61,7 @@

 	    (send-html/finish
 	     `(html (body (h1 "Result 2")
+			  (p "called " ,(length global) " times")
 			  ,(format #f "~s" (get-bindings req))
 			  (hr)
 			  (p (URL "test.scm" "Test again.") (br)