scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

+ 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
This commit is contained in:
interp 2003-03-09 20:15:08 +00:00
parent 31f0044e2c
commit 3b51f7b82b
13 changed files with 109 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
scheme/httpd/surflets/packages.scm
View File

@ -120,7 +120,12 @@
my-session-id my-session-id
my-continuation-id my-continuation-id
my-ids))) my-ids
surflet-form-rules
default-rules
url-rule
plain-html-rule)))
;; THE interface that SUrflets use. ;; THE interface that SUrflets use.
(define-interface surflet-interface (define-interface surflet-interface

2
scheme/httpd/surflets/simple-surflet-api.scm
View File

@ -66,7 +66,7 @@
(br) (br)
(p ,@text) (p ,@text)
(br) (br)
(URL ,url "Continue")))))) (url ,url "Continue"))))))
;; Post some information on a Web page, shut down the surflet and all ;; Post some information on a Web page, shut down the surflet and all
;; its continuations. ;; its continuations.

68
scheme/httpd/surflets/surflets.scm
View File

@ -165,27 +165,30 @@
(define (reformat html-tree) (define (reformat html-tree)
(pre-post-order (pre-post-order
html-tree html-tree
`( `(,@default-rules
;; Universal transformation rules. Works for every HTML, ;; form contents:
;; present and future ,@surflet-form-rules)))
,@default-rules
(,input-field-trigger ;; Used in input-fields as well
*preorder* (define *input-field-trigger* '*input-field*)
. ,(lambda (trigger input-field)
(reformat (input-field-html-tree input-field)))) (define surflet-form-rules
`((,*input-field-trigger*
(surflet-form *preorder*
;; Must do something to prevent the k-url string to be HTML . ,(lambda (trigger input-field)
;; escaped. (reformat (input-field-html-tree input-field))))
*preorder*
. ,(lambda (trigger k-url . args) (surflet-form
(receive (parameters elems) ;; Must do something to prevent the k-url string to be HTML
(typed-optionals (list symbol? xml-attribute?) args) ;; escaped.
(make-surflet-form k-url ; k-url *preorder*
(car parameters) ; POST, GET or #f=GET . ,(lambda (trigger k-url . args)
(cadr parameters); attributes (receive (parameters elems)
elems))))) ; form-content (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) (define (make-surflet-form k-url method attributes elems)
(let ((real-method (case method (let ((real-method (case method
@ -223,11 +226,11 @@
(if (string? str) (string->goodHTML str) str)))) (if (string? str) (string->goodHTML str) str))))
(define url-rule (define url-rule
(cons 'URL (cons 'url
(lambda (tag URI . maybe-text) (lambda (tag uri . maybe-text)
(list "<a href=\"" URI "\">" (list "<a href=\"" uri "\">"
(if (null? maybe-text) (if (null? maybe-text)
URI uri
maybe-text) maybe-text)
"</a>")))) "</a>"))))
@ -279,7 +282,7 @@
(p "The page or action you requested relies on outdated data.") (p "The page or action you requested relies on outdated data.")
,(if url ,(if url
`(p "Try to " `(p "Try to "
(URL ,url "reload") (url ,url "reload")
" the page to get current data.") " the page to get current data.")
'()))))) '())))))
@ -304,12 +307,11 @@
(input-field-name input-field)))) (input-field-name input-field))))
;; Have to do a trick to get around with SSAX: input-field is a list ;; 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. ;; is a real input-field.
(define input-field-trigger '*input-field*)
(define (input-field? input-field) (define (input-field? input-field)
(and (pair? 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)))) (real-input-field? (cadr input-field))))
;; FIXME: consider creating small names ;; FIXME: consider creating small names
@ -324,10 +326,12 @@
;; See note at input-field? for reasons for the list. ;; See note at input-field? for reasons for the list.
(define (make-input-field name transformer html-tree) (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) (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 ;; PRED-LIST contains list of predicates that recognizes optional
;; leading parameters. FURTHER-ATTRIBUTES is the optional parameter ;; leading parameters. FURTHER-ATTRIBUTES is the optional parameter
@ -637,7 +641,7 @@
;; (send-html/suspend ;; (send-html/suspend
;; (lambda (new-url) ;; (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 (define-record-type address :address
(really-make-address name annotated?) (really-make-address name annotated?)

4
scheme/httpd/surflets/web-server/root/surflets/add-html.scm
View File

@ -23,8 +23,8 @@
(name "number")) (name "number"))
(input (@ (type "submit")))))) (input (@ (type "submit"))))))
(hr) (hr)
(p (URL "/" "Return to main menu") (br) (p (url "/" "Return to main menu") (br)
(URL "add-html.scm" "Start new calculation.")))))))) (url "add-html.scm" "Start new calculation."))))))))
(let* ((bindings (form-query-list (let* ((bindings (form-query-list
(http-url-search (surflet-request-url result)))) (http-url-search (surflet-request-url result))))
(number (string->number (number (string->number

10
scheme/httpd/surflets/web-server/root/surflets/add-surflet.scm
View File

@ -16,8 +16,8 @@
,number-input-field ,number-input-field
,(make-submit-button))) ,(make-submit-button)))
(hr) (hr)
(p (URL "/" "Return to main menu.") (br) (p (url "/" "Return to main menu.") (br)
(URL "add-surflet.scm" "Start new calculation.")))))) (url "add-surflet.scm" "Start new calculation."))))))
(define (get-number title input-text) (define (get-number title input-text)
(let* ((result (send-html/suspend (let* ((result (send-html/suspend
@ -40,10 +40,10 @@
(body (h2 "Result") (body (h2 "Result")
(p ,(+ (get-number-1) (get-number-2)) (p ,(+ (get-number-1) (get-number-2))
(hr) (hr)
(p (URL "add-surflet.scm" "Make new calculation.") (br) (p (url "add-surflet.scm" "Make new calculation.") (br)
(URL "javascript:history.go(-2)" "New calculation (same session)") (url "javascript:history.go(-2)" "New calculation (same session)")
(br) (br)
(URL "/" "Return to main menu.")))))) (url "/" "Return to main menu."))))))
"this string will never be evaluated") "this string will never be evaluated")
)) ))

4
scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm
View File

@ -31,8 +31,8 @@
(td ,submit-button)))) (td ,submit-button))))
options))) options)))
(hr) (hr)
(p (URL ,(return-address new-url) "Return to adminstration menu.") (br) (p (url ,(return-address new-url) "Return to adminstration menu.") (br)
(URL "/" "Return to main menu.")))) (url "/" "Return to main menu."))))
))) )))
(define submit-timeout (make-submit-button "Change")) (define submit-timeout (make-submit-button "Change"))

27
scheme/httpd/surflets/web-server/root/surflets/admin-surflets-cb.scm
View File

@ -70,7 +70,7 @@
(define (no-surflets) (define (no-surflets)
`(p "Currently, there are no SUrflets loaded " `(p "Currently, there are no SUrflets loaded "
(URL ,(make-callback surflets) "(reload)."))) (url ,(make-callback surflets) "(reload).")))
(define (surflets req . maybe-update-text) (define (surflets req . maybe-update-text)
(let* ((update-text (:optional maybe-update-text "")) (let* ((update-text (:optional maybe-update-text ""))
@ -81,7 +81,7 @@
(h2 "SUrflets") (h2 "SUrflets")
(p (font (@ (color "red")) ,update-text)))) (p (font (@ (color "red")) ,update-text))))
(footer `((hr) (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"))) (actions '("unload" "unload all" "view sessions")))
(if (null? loaded-surflets) (if (null? loaded-surflets)
(send-html `(html (title ,title) (body ,header ,(no-surflets) ,footer))) (send-html `(html (title ,title) (body ,header ,(no-surflets) ,footer)))
@ -98,7 +98,7 @@
`(p "Note that unloading the SUrflet does not imply " `(p "Note that unloading the SUrflet does not imply "
"the unloading of sessions of this SUrflet." "the unloading of sessions of this SUrflet."
"This can be done on the " "This can be done on the "
(URL ,(make-callback sessions) (url ,(make-callback sessions)
"sessions adminstration page.")) "sessions adminstration page."))
footer)) footer))
(if (null? selected-surflets) (if (null? selected-surflets)
@ -147,7 +147,7 @@
'(p "Currently, there are no sessions, " '(p "Currently, there are no sessions, "
"i.e. the administration SUrflet is no longer running. " "i.e. the administration SUrflet is no longer running. "
;; Can't use callback here, as there are no valid sessions left. ;; 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) (define (sessions req . maybe-update-text)
(let* ((update-text (:optional maybe-update-text "")) (let* ((update-text (:optional maybe-update-text ""))
@ -161,7 +161,7 @@
(h2 "Sessions") (h2 "Sessions")
(p (font (@ (color "red")) ,update-text)))) (p (font (@ (color "red")) ,update-text))))
(footer `((hr) (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" (actions '("kill"
"adjust timeout" "adjust timeout"
"view continuations")) "view continuations"))
@ -210,11 +210,11 @@
(define (no-current-continuations session) (define (no-current-continuations session)
`((p "Currently, there are no continuations for this 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)))) (lambda (req) (continuations (list session))))
"reload") "reload")
" this page or go back to the " " 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) (define (no-more-than-one-session title header1)
(send-html (send-html
@ -224,7 +224,7 @@
"one session at a time. This will be changed in " "one session at a time. This will be changed in "
"future revisions. Sorry for any inconvenience.") "future revisions. Sorry for any inconvenience.")
(p "You may choose to go back to the " (p "You may choose to go back to the "
(URL ,(make-callback sessions) (url ,(make-callback sessions)
"sessions administration page") "sessions administration page")
" where you can choose one session."))))) " where you can choose one session.")))))
@ -252,11 +252,14 @@
(p (font (@ (color "red")) ,update-text))))) (p (font (@ (color "red")) ,update-text)))))
(footer (footer
`((hr) `((hr)
(URL ,(make-callback sessions) "Return to sessions page.") (br) (url ,(make-callback sessions)
(URL ,(make-callback return-to-main-page) "Return to main page."))) "Return to sessions page.") (br)
(url ,(make-callback return-to-main-page)
"Return to main page.")))
(actions '("delete" "delete all")) (actions '("delete" "delete all"))
(continuations-callback (make-callback (lambda (req) (continuations-callback
(continuations sessions))))) (make-callback (lambda (req)
(continuations sessions)))))
(if (null? current-continuations) (if (null? current-continuations)
(send-html `(html (title ,title) (send-html `(html (title ,title)
(body ,header (body ,header

8
scheme/httpd/surflets/web-server/root/surflets/admin.scm
View File

@ -12,11 +12,11 @@
(p "Choose one of the following submenus:") (p "Choose one of the following submenus:")
(p (p
(ul (ul
(li (URL "admin-handler.scm" "Set handler options...")) (li (url "admin-handler.scm" "Set handler options..."))
(li (URL "admin-surflets.scm" "SUrflets...")) (li (url "admin-surflets.scm" "SUrflets..."))
(li (URL "admin-profiling.scm" "Profiling...")))) (li (url "admin-profiling.scm" "Profiling..."))))
(hr) (hr)
(p (URL "/" "Return to main menu."))))) (p (url "/" "Return to main menu.")))))
(define (main req) (define (main req)
(send-html (main-page))) (send-html (main-page)))

6
scheme/httpd/surflets/web-server/root/surflets/byte-input.scm
View File

@ -40,8 +40,8 @@
(h2 "Result") (h2 "Result")
(p "You've entered " ,result ".") (p "You've entered " ,result ".")
(hr) (hr)
(p (URL "byte-input.scm" "Make new byte input.") (br) (p (url "byte-input.scm" "Make new byte input.") (br)
(URL "/" "Return to main menu.")))))) (url "/" "Return to main menu."))))))
(define (get-byte-input) (define (get-byte-input)
(let* ((req (send-html/suspend (let* ((req (send-html/suspend
@ -54,7 +54,7 @@
,byte-input-fields ,byte-input-fields
,(make-submit-button)) ,(make-submit-button))
(hr) (hr)
(p (URL "/" "Return to main menu."))))))) (p (url "/" "Return to main menu.")))))))
(bindings (get-bindings req))) (bindings (get-bindings req)))
(input-field-value byte-input-fields bindings))) (input-field-value byte-input-fields bindings)))

6
scheme/httpd/surflets/web-server/root/surflets/calculate.scm
View File

@ -66,7 +66,7 @@
(tr (td ,operator-input-field) (tr (td ,operator-input-field)
(td ,change-button))) (td ,change-button)))
(hr) (hr)
(p (URL "/" "Return to main menu.")))))))) (p (url "/" "Return to main menu."))))))))
(bindings (get-bindings req))) (bindings (get-bindings req)))
(let ((number1 (input-field-value number-field1 bindings)) (let ((number1 (input-field-value number-field1 bindings))
(number2 (input-field-value number-field2 bindings))) (number2 (input-field-value number-field2 bindings)))
@ -105,8 +105,8 @@
(p ,number1 " " ,operator-symbol " " ,number2 (p ,number1 " " ,operator-symbol " " ,number2
" = " ,result) " = " ,result)
(hr) (hr)
(p (URL "calculate.scm" "Make new calculation") (br) (p (url "calculate.scm" "Make new calculation") (br)
(URL "/" "Return to main menu.")))))) (url "/" "Return to main menu."))))))
(define (main req) (define (main req)
(show-page (car *operator-alist*) #f #f) (show-page (car *operator-alist*) #f #f)

8
scheme/httpd/surflets/web-server/root/surflets/news.scm
View File

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

6
scheme/httpd/surflets/web-server/root/surflets/spaceship.scm
View File

@ -469,13 +469,13 @@ spaceships of class " ,class ":")
,(return-links first-page-return-link main-return-link)))) ,(return-links first-page-return-link main-return-link))))
(define main-return-link (define main-return-link
'(URL "/" "Return to main menu.")) '(url "/" "Return to main menu."))
(define (previous-page-return-link prev) (define (previous-page-return-link prev)
`(URL ,prev "Return to previous page.")) `(url ,prev "Return to previous page."))
(define first-page-return-link (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) (define (return-links . links)
`(p `(p

29
scheme/httpd/surflets/web-server/root/surflets/test.scm
View File

@ -3,34 +3,54 @@
surflets surflets
httpd-responses) httpd-responses)
(begin (begin
(define global '())
(define select (make-select-input-field '("a" "b" "c") #t '(@ (size 2)))) (define select (make-select-input-field '("a" "b" "c") #t '(@ (size 2))))
(define (main req) (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) (lambda (new-url)
`(html (body (h1 "This is from SUrflet") `(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 (surflet-form
,new-url ,new-url
POST POST
,select ,select
'(input (@ (type "text") (name "TeST")))
,(make-submit-button)) ,(make-submit-button))
(hr) (hr)
(p (URL "/" "Return to main menu.")) (p (URL "/" "Return to main menu."))
))))) )))))
(save-k #f) (save-k #f)
(done? #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 (call-with-current-continuation
(lambda (k) (lambda (k)
(set! save-k k) (set! save-k k)
13)) 13))
(set! global (cons 1 global))
(if (not done?) (if (not done?)
(begin (begin
(send-html/suspend (send-html/suspend
(lambda (continue) (lambda (continue)
`(html (body (h1 "Result") `(html (body (h1 "Result")
,(format #f "~s" (get-bindings req)) (br) (p "called " ,(length global) " times")
,result (br)
(URL ,continue "show results again") (URL ,continue "show results again")
(hr) (hr)
(p (URL "test.scm" "Test again.") (br) (p (URL "test.scm" "Test again.") (br)
@ -41,6 +61,7 @@
(send-html/finish (send-html/finish
`(html (body (h1 "Result 2") `(html (body (h1 "Result 2")
(p "called " ,(length global) " times")
,(format #f "~s" (get-bindings req)) ,(format #f "~s" (get-bindings req))
(hr) (hr)
(p (URL "test.scm" "Test again.") (br) (p (URL "test.scm" "Test again.") (br)