diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm
index f578c6b..30a43bb 100644
--- 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
diff --git a/scheme/httpd/surflets/simple-surflet-api.scm b/scheme/httpd/surflets/simple-surflet-api.scm
index 5d0b911..306ec5b 100644
--- 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.
diff --git a/scheme/httpd/surflets/surflets.scm b/scheme/httpd/surflets/surflets.scm
index a12fb1a..d3f1c02 100644
--- 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 ""
+ (cons 'url
+ (lambda (tag uri . maybe-text)
+ (list ""
(if (null? maybe-text)
- URI
+ uri
maybe-text)
""))))
@@ -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?)
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 8276a66..89f9102 100644
--- 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
diff --git a/scheme/httpd/surflets/web-server/root/surflets/add-surflet.scm b/scheme/httpd/surflets/web-server/root/surflets/add-surflet.scm
index e0894e5..f2bcde8 100644
--- 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")
))
diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm
index ae42e61..c8cab58 100644
--- 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"))
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 c4cebda..71f22fd 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
@@ -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
diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin.scm b/scheme/httpd/surflets/web-server/root/surflets/admin.scm
index 085481d..87867ee 100644
--- 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)))
diff --git a/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm b/scheme/httpd/surflets/web-server/root/surflets/byte-input.scm
index 74a848d..f752d29 100644
--- 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)))
diff --git a/scheme/httpd/surflets/web-server/root/surflets/calculate.scm b/scheme/httpd/surflets/web-server/root/surflets/calculate.scm
index 43de851..8d14fe7 100644
--- 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)
diff --git a/scheme/httpd/surflets/web-server/root/surflets/news.scm b/scheme/httpd/surflets/web-server/root/surflets/news.scm
index a3ee15b..98a7769 100644
--- 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.")))))))
))
diff --git a/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm b/scheme/httpd/surflets/web-server/root/surflets/spaceship.scm
index d40cef0..783b48f 100644
--- 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
diff --git a/scheme/httpd/surflets/web-server/root/surflets/test.scm b/scheme/httpd/surflets/web-server/root/surflets/test.scm
index 24df3c1..b9258e3 100644
--- 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
+ (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)