From 3b51f7b82b2652e73cdf71682904efce56514dce Mon Sep 17 00:00:00 2001 From: interp Date: Sun, 9 Mar 2003 20:15:08 +0000 Subject: [PATCH] + 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 --- scheme/httpd/surflets/packages.scm | 7 +- scheme/httpd/surflets/simple-surflet-api.scm | 2 +- scheme/httpd/surflets/surflets.scm | 68 ++++++++++--------- .../web-server/root/surflets/add-html.scm | 4 +- .../web-server/root/surflets/add-surflet.scm | 10 +-- .../root/surflets/admin-handler.scm | 4 +- .../root/surflets/admin-surflets-cb.scm | 27 ++++---- .../web-server/root/surflets/admin.scm | 8 +-- .../web-server/root/surflets/byte-input.scm | 6 +- .../web-server/root/surflets/calculate.scm | 6 +- .../web-server/root/surflets/news.scm | 8 +-- .../web-server/root/surflets/spaceship.scm | 6 +- .../web-server/root/surflets/test.scm | 29 ++++++-- 13 files changed, 109 insertions(+), 76 deletions(-) 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)