+ Splitting file surflets.scm into several packages
- Removing surflets.scm
+ The surflets package remains and collects the most usual used packages
It does not export any more the outdaters, the access to IDs
(like session-id), callbacks, form-query-list.
(and maybe some other stuff I've forgot to mention here, see list
below).
The new packages are (not included in surflets are marked (*)):
+ surflets/addresses: MAKE-ADDRESS, MAKE-ANNOTATED-ADDRESS
+ surflets/bindings: GET-BINDINGS, EXTRACT-BINDINGS and stuff
+ surflets/ids (*): MY-SESSION-ID, .., INSTANCE-SESSION-ID
+ surflets/input-fields: MAKE-INPUT-FIELD, MAKE-NUMBER-INPUT-FIELD...
+ surflets/outdaters(*): MAKE-OUTDATER, OUTDATER?...
+ surflets/returned-via: RETURNED-VIA, CASE-RETURNED-VIA
+ surflets/send-html: SEND-HTML/SUSPEND...
+ surflets/surflet-sxml: URL-RULE,..., SURLFET-SXML-RULES, ...
+ surflets/sxml: SXML->STRING, DEFAULT-RULE,...
+ surflets/typed-optionals(*): TYPED-OPTIONALS, OPTIONALS
+ surflets/utilities(*): MAKE-CALLBACK, FORM-QUERY-LIST,
GENERATE-UNIQUE-NAME...
This commit is contained in:
interp
parent
87a4165f94
commit
3fc36e865e
|
|
@ -0,0 +1,48 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; return address
|
||||
|
||||
;; generates an unique return-addres
|
||||
;; may be used like
|
||||
;; (let ((address (make-address)))
|
||||
;; (send-html/suspend
|
||||
;; (lambda (new-url)
|
||||
;; ...
|
||||
;; (url (address new-url) "Click here to get more")...)
|
||||
|
||||
(define-record-type address :address
|
||||
(really-make-address name annotated?)
|
||||
(name real-address-name)
|
||||
(annotated? real-address-annotated?))
|
||||
|
||||
(define (make-address)
|
||||
(let ((address (really-make-address
|
||||
(generate-unique-name "return") #f)))
|
||||
(lambda (message)
|
||||
(cond
|
||||
((string? message)
|
||||
(string-append message "?" (real-address-name address) "="))
|
||||
((eq? message 'address)
|
||||
address)
|
||||
(else
|
||||
(error "address: unknown message/bad argument"
|
||||
message (real-address-name address)))))))
|
||||
|
||||
(define (make-annotated-address)
|
||||
(let ((address (really-make-address
|
||||
(generate-unique-name "return")
|
||||
#t)))
|
||||
(lambda (message . annotation)
|
||||
(cond
|
||||
((and (string? message)
|
||||
(<= (length annotation) 1))
|
||||
(let ((escaped-annotation
|
||||
(if (null? annotation)
|
||||
""
|
||||
(escape-uri (car annotation)))))
|
||||
(string-append message "?" (real-address-name address)
|
||||
"=" escaped-annotation)))
|
||||
((eq? message 'address)
|
||||
address)
|
||||
(else
|
||||
(error "annotated-address: unknown message/bad argument(s)"
|
||||
message (real-address-name address)))))))
|
||||
|
|
@ -0,0 +1,89 @@
|
|||
;; Copyright 2002, 2003 Andreas Bernauer
|
||||
|
||||
;; Bindings of POST requests can be read only once, since they are
|
||||
;; read from an input port. So we have to cache them, for the case of
|
||||
;; a later GET-BINDINGS call on the same POST request. The requests
|
||||
;; are referenced by a weak pointer. Thread-safe as all threads use
|
||||
;; the same lock.
|
||||
(define *POST-bindings-cache* '())
|
||||
(define *cache-lock* (make-lock))
|
||||
|
||||
(define (get-bindings surflet-request)
|
||||
(let ((request-method (surflet-request-method surflet-request)))
|
||||
(cond
|
||||
((string=? request-method "GET")
|
||||
(form-query-list (http-url-search
|
||||
(surflet-request-url surflet-request))))
|
||||
((string=? request-method "POST")
|
||||
(or (cached-bindings surflet-request)
|
||||
(let* ((content-length (get-content-length
|
||||
(surflet-request-headers surflet-request)))
|
||||
(input-port (surflet-request-input-port surflet-request))
|
||||
(form-data (read-string content-length input-port)))
|
||||
(let ((form-bindings (form-query-list form-data)))
|
||||
(obtain-lock *cache-lock*)
|
||||
(set! *POST-bindings-cache* (cons (cons (make-weak-pointer surflet-request)
|
||||
form-bindings)
|
||||
*POST-bindings-cache*))
|
||||
(release-lock *cache-lock*)
|
||||
form-bindings))))
|
||||
(else
|
||||
(error "unsupported request type")))))
|
||||
|
||||
;; Looking up, if we have cached this request. While going through the
|
||||
;; list, we remove entries to request objects, that are no longer
|
||||
;; valid. Expecting a call for an uncached request every now and then,
|
||||
;; it is guaranteed, that the list is cleaned up every now and
|
||||
;; then. The cache is a list of pairs
|
||||
;;; (surflet-request . computed-binding)
|
||||
(define (cached-bindings surflet-request)
|
||||
(obtain-lock *cache-lock*)
|
||||
(let ((result
|
||||
(let loop ((cache *POST-bindings-cache*))
|
||||
(if (null? cache)
|
||||
#f ; no such request cached
|
||||
(let* ((head (car cache))
|
||||
(s-req (weak-pointer-ref (car head))))
|
||||
(if s-req
|
||||
(if (eq? s-req surflet-request)
|
||||
(cdar cache) ; request is cached
|
||||
(loop (cdr cache))) ; request isn't cached
|
||||
(begin
|
||||
;; request object is gone ==> remove it from list
|
||||
(set! cache (cdr cache))
|
||||
(loop cache))))))))
|
||||
(release-lock *cache-lock*)
|
||||
result))
|
||||
|
||||
|
||||
;; Will be needed when we handle POST requests.
|
||||
(define (get-content-length headers)
|
||||
(cond ((get-header headers 'content-length) =>
|
||||
;; adopted from httpd/cgi-server.scm
|
||||
(lambda (content-length) ; Skip initial whitespace (& other non-digits).
|
||||
(let ((first-digit (string-index content-length char-set:digit))
|
||||
(content-length-len (string-length content-length)))
|
||||
(if first-digit
|
||||
(string->number (substring content-length first-digit
|
||||
content-length-len))
|
||||
;; (status-code bad-request) req
|
||||
(error "Illegal `Content-length:' header.")))))
|
||||
(else
|
||||
(error "No Content-length specified for POST data."))))
|
||||
|
||||
(define (extract-bindings key bindings)
|
||||
(let ((key (if (symbol? key) (symbol->string key) key)))
|
||||
(map cdr
|
||||
(filter (lambda (binding)
|
||||
(equal? (car binding) key))
|
||||
bindings))))
|
||||
|
||||
(define (extract-single-binding key bindings)
|
||||
(let ((key-bindings (extract-bindings key bindings)))
|
||||
(if (= 1 (length key-bindings))
|
||||
(car key-bindings)
|
||||
(error "extract-one-binding: more than one or zero bindings found"
|
||||
(length key-bindings)
|
||||
key bindings))))
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
(define (surflet-file-name req)
|
||||
(last (http-url-path (surflet-request-url req))))
|
||||
|
||||
;; This works for all requests except for the initial one. For the
|
||||
;; initial one (main's arg) think about using instance-session-id.
|
||||
(define (my-session-id req)
|
||||
(resume-url-session-id (surflet-file-name req)))
|
||||
|
||||
;; This works for all requests except for the initial one: we don't
|
||||
;; have a continuation at this time.
|
||||
(define (my-continuation-id req)
|
||||
(resume-url-continuation-id (surflet-file-name req)))
|
||||
|
||||
;; Returns two values: session-id and continuation-id. The
|
||||
;; restrictions from my-session-id and my-continuation-id apply here
|
||||
;; as well.
|
||||
(define (my-ids req)
|
||||
(resume-url-ids (surflet-file-name req)))
|
||||
|
||||
|
|
@ -0,0 +1,281 @@
|
|||
;;; Copyright 2002, 2003 Andreas Bernauer
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; input-fields
|
||||
;;; defines input-fields for surflets
|
||||
|
||||
(define *input-field-trigger* `*input-field*)
|
||||
|
||||
;; GET-BINDINGS?: Transformer will get all bindings of request, not
|
||||
;; only the one concerning the input-field.
|
||||
(define-record-type input-field :input-field
|
||||
(real-make-input-field name transformer html-tree get-bindings?)
|
||||
real-input-field?
|
||||
(name input-field-name)
|
||||
(transformer input-field-transformer)
|
||||
(attributes input-field-attributes)
|
||||
(html-tree input-field-html-tree)
|
||||
(get-bindings? input-field-get-bindings?))
|
||||
|
||||
(define-record-discloser :input-field
|
||||
(lambda (input-field)
|
||||
(list 'input-field
|
||||
(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
|
||||
;; is a real input-field.
|
||||
(define (input-field? input-field)
|
||||
(and (pair? input-field)
|
||||
(eq? *input-field-trigger* (car input-field))
|
||||
(real-input-field? (cadr input-field))))
|
||||
|
||||
;; FIXME: consider creating small names
|
||||
(define generate-unique-name
|
||||
(let ((id 0))
|
||||
(lambda (type-string)
|
||||
(set! id (+ 1 id))
|
||||
(string-append type-string (number->string id)))))
|
||||
|
||||
(define generate-input-field-name generate-unique-name)
|
||||
|
||||
(define identity (lambda (a) a))
|
||||
|
||||
;; 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)))
|
||||
|
||||
(define (make-higher-input-field transformer html-tree)
|
||||
(list *input-field-trigger*
|
||||
(real-make-input-field #f transformer html-tree #t)))
|
||||
|
||||
(define (make-text-input-field . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "text")))
|
||||
(optionals maybe-further-attributes
|
||||
((default-text string?)
|
||||
(attributes sxml-attribute?))
|
||||
(make-input-field name
|
||||
identity
|
||||
`(input (@ (type "text")
|
||||
(name ,name)
|
||||
,(and default-text `(value ,default-text))
|
||||
;; this will insert a list, but
|
||||
;; XML->HTML doesn't care about it
|
||||
,(and attributes (cdr attributes))
|
||||
))))))
|
||||
|
||||
(define make-number-input-field
|
||||
(let ((number-input-field-transformer
|
||||
(lambda (string)
|
||||
(or (string->number string)
|
||||
(error "wrong type")))
|
||||
))
|
||||
(lambda maybe-further-attributes
|
||||
(let ((name (generate-input-field-name "number")))
|
||||
(optionals maybe-further-attributes
|
||||
((default (lambda (a) (or (number? a)
|
||||
(string-or-symbol? a))))
|
||||
(attributes sxml-attribute?))
|
||||
(make-input-field
|
||||
name
|
||||
number-input-field-transformer
|
||||
`(input (@ (type "text")
|
||||
(name ,name)
|
||||
,(and default `(value ,default))
|
||||
,(and attributes (cdr attributes))))))))))
|
||||
|
||||
(define (make-password-input-field . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "password")))
|
||||
(optionals maybe-further-attributes
|
||||
((attributes sxml-attribute?))
|
||||
(make-input-field
|
||||
name
|
||||
identity
|
||||
`(input (@ (type "password")
|
||||
(name ,name)
|
||||
,(and attributes (cdr attributes))))))))
|
||||
|
||||
(define (make-textarea-input-field . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "textarea")))
|
||||
(optionals maybe-further-attributes
|
||||
((default-text string?)
|
||||
(attributes sxml-attribute?))
|
||||
(make-input-field
|
||||
name
|
||||
identity
|
||||
`(textarea (@ (type "textarea")
|
||||
(name ,name)
|
||||
,(and attributes (cdr attributes)))
|
||||
,(and default-text))))))
|
||||
|
||||
;(make-select-input-fields '("this" "that" "those") '(@ ((id "sushi"))))
|
||||
;(make-select-input-fields '("this" ("that" '(@ (selected))) "those"))
|
||||
;; dropdown: (size 1)
|
||||
;; multiple choice: (multiple)
|
||||
;; preselected option: (selected)
|
||||
;; changed return value: (value new-value)
|
||||
;; returns a select input field with several options
|
||||
(define make-select-input-field
|
||||
(let ((make-multiple-transformer
|
||||
(lambda (name)
|
||||
(lambda (bindings)
|
||||
(map cdr
|
||||
(filter (lambda (binding)
|
||||
(equal? (car binding) name))
|
||||
bindings))))))
|
||||
|
||||
(lambda (options . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((multiple? boolean?)
|
||||
(attributes sxml-attribute?))
|
||||
(let* ((name (generate-input-field-name "select"))
|
||||
(sxml-options
|
||||
(map (lambda (option)
|
||||
(cond
|
||||
((string-or-symbol? option)
|
||||
(list 'option option))
|
||||
((list? option)
|
||||
(cond
|
||||
((null? (cdr option))
|
||||
`(option ,option))
|
||||
((sxml-attribute? (cdr option)) ; w/attribs?
|
||||
`(option ,(cdr option) ,(car option)))
|
||||
(else
|
||||
(error "not an attribute" (cdr option)))))
|
||||
(else
|
||||
(error "not an option" option))))
|
||||
options))
|
||||
(sxml `(select (@ ((name ,name)
|
||||
,(if multiple? '(multiple) '())
|
||||
,(and attributes (cdr attributes))))
|
||||
#\newline
|
||||
,sxml-options)))
|
||||
(if multiple?
|
||||
(make-higher-input-field (make-multiple-transformer name) sxml)
|
||||
(make-input-field name identity sxml)))))))
|
||||
|
||||
;; returns a *list* of radio buttons
|
||||
(define (make-radio-input-fields values . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "radio")))
|
||||
(optionals maybe-further-attributes
|
||||
((attributes sxml-attribute?))
|
||||
(map (lambda (value)
|
||||
(let ((value-value (if (pair? value) (car value) value))
|
||||
(value-attributes (if (pair? value)
|
||||
(if (sxml-attribute? (cdr value))
|
||||
(cddr value)
|
||||
(error "not an attribute" cdr value))
|
||||
#f)))
|
||||
(make-input-field
|
||||
name
|
||||
(lambda (select)
|
||||
select)
|
||||
`(input (@ ((type "radio")
|
||||
(name ,name)
|
||||
(value ,value-value)
|
||||
,(and value-attributes)
|
||||
,(and attributes (cdr attributes))))))))
|
||||
values))))
|
||||
|
||||
;; returns a checkbox input field
|
||||
(define (make-checkbox-input-field . maybe-further-attributes)
|
||||
(let* ((name (generate-input-field-name "checkbox")))
|
||||
(optionals maybe-further-attributes
|
||||
((checked? boolean?)
|
||||
(value (lambda (a) (or (string? a)
|
||||
(number? a)
|
||||
(symbol? a))))
|
||||
(attributes sxml-attribute?))
|
||||
(make-input-field
|
||||
name
|
||||
(lambda (value)
|
||||
(or (string=? value "on")
|
||||
value))
|
||||
`(input (@ ((type "checkbox")
|
||||
(name ,name)
|
||||
,(if value `(value ,value) '())
|
||||
,(if checked? '(checked) '())
|
||||
,(and attributes (cdr attributes)))))))))
|
||||
|
||||
|
||||
(define (make-hidden-input-field value . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "hidden")))
|
||||
(optionals maybe-further-attributes
|
||||
((attributes sxml-attribute?))
|
||||
(make-input-field name
|
||||
identity
|
||||
`(input (@ (type "hidden")
|
||||
(name ,name)
|
||||
(value ,value)
|
||||
,(and attributes (cdr attributes))))))))
|
||||
|
||||
(define (make-button type name button-caption attributes)
|
||||
(make-input-field name
|
||||
identity
|
||||
`(input (@ (type ,type)
|
||||
(name ,name)
|
||||
,(and button-caption `(value ,button-caption))
|
||||
,(and attributes (cdr attributes))))))
|
||||
|
||||
(define (string-or-symbol? a)
|
||||
(or (string? a)
|
||||
(symbol? a)))
|
||||
|
||||
(define (make-submit-button . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((button-caption string-or-symbol?)
|
||||
(attributes sxml-attribute?))
|
||||
(make-button "submit" (generate-input-field-name "submit")
|
||||
button-caption attributes)))
|
||||
|
||||
(define (make-reset-button . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((button-caption string-or-symbol?)
|
||||
(attributes sxml-attribute?))
|
||||
(make-button "reset" (generate-input-field-name "reset")
|
||||
button-caption attributes)))
|
||||
|
||||
(define (make-image-button image-source . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((attributes sxml-attribute?))
|
||||
(make-button "image" (generate-input-field-name "imgbtn")
|
||||
#f `(@ (src ,image-source)
|
||||
,@(if attributes (cdr attributes) '())))))
|
||||
|
||||
;; <input-field>: '(input-field . <real-input-field>)
|
||||
;; <real-input-field>: #{Input-field "name"}
|
||||
(define (raw-input-field-value input-field bindings)
|
||||
(let ((input-field (cadr input-field)))
|
||||
(cond
|
||||
((input-field-get-bindings? input-field)
|
||||
((input-field-transformer input-field) bindings))
|
||||
((real-input-field-binding input-field bindings) =>
|
||||
(lambda (binding)
|
||||
((input-field-transformer input-field) (cdr binding))))
|
||||
(else
|
||||
(error "no such input-field" input-field bindings)))))
|
||||
|
||||
;; Trys to get a value for INPUT-FIELD in BINDINGS. If this fails
|
||||
;; (i.e. RAW-INPUT-FIELD-VALUE returns an error), the default-value is
|
||||
;; returned. The default-value defaults to #f. NOTE: If you do this
|
||||
;; with input-fields whose valid values may be the same as the default
|
||||
;; value, you cannot determine by the result if there was such a value
|
||||
;; or not. Keep in mind, that RAW-INPUT-FIELD-VALUE returns also an
|
||||
;; error, if there was not such an input field. This makes
|
||||
;; INPUT-FIELD-VALUE working with checkbox input fields because they
|
||||
;; miss if they are not checked.
|
||||
(define (input-field-value input-field bindings . maybe-default)
|
||||
(let ((default (:optional maybe-default #f)))
|
||||
(with-fatal-error-handler
|
||||
(lambda (condition more)
|
||||
default)
|
||||
(raw-input-field-value input-field bindings))))
|
||||
|
||||
(define (real-input-field-binding input-field bindings)
|
||||
(assoc (input-field-name input-field) bindings))
|
||||
|
||||
(define (input-field-binding input-field bindings)
|
||||
(real-input-field-binding (cadr input-field) bindings))
|
||||
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
;;; Copyright 2002, 2003 Andreas Bernauer
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; outdater
|
||||
|
||||
(define-record-type outdater :outdater
|
||||
(real-make-outdater outdated?)
|
||||
outdater?
|
||||
(outdated? outdater-outdated? set-outdater-outdated?!))
|
||||
|
||||
(define (make-outdater)
|
||||
(real-make-outdater #f))
|
||||
|
||||
(define-syntax if-outdated
|
||||
(syntax-rules ()
|
||||
((if-outdated outdater consequence alternative)
|
||||
(if (outdater-outdated? outdater)
|
||||
consequence
|
||||
(begin
|
||||
(set-outdater-outdated?! outdater #t)
|
||||
alternative)))))
|
||||
|
||||
(define (show-outdated url)
|
||||
(send-html
|
||||
`(html (title "Outdated Data")
|
||||
(body (h1 "Outdated Data")
|
||||
(p "The page or action you requested relies on outdated data.")
|
||||
,(if url
|
||||
`(p "Try to "
|
||||
(url ,url "reload")
|
||||
" the page to get current data.")
|
||||
'())))))
|
||||
|
|
@ -68,65 +68,6 @@
|
|||
resume-url-session-id
|
||||
resume-url-continuation-id))
|
||||
|
||||
|
||||
|
||||
;; Helping functions for surflets
|
||||
(define-interface surflets-interface
|
||||
(compound-interface
|
||||
surflet-handler/surflets-interface
|
||||
(export send-html/suspend
|
||||
send-html/finish
|
||||
send-html
|
||||
|
||||
form-query-list
|
||||
get-bindings
|
||||
extract-bindings
|
||||
extract-single-binding
|
||||
|
||||
adjust-timeout!
|
||||
|
||||
make-outdater
|
||||
(if-outdated :syntax)
|
||||
show-outdated
|
||||
|
||||
generate-input-field-name
|
||||
make-input-field
|
||||
make-higher-input-field
|
||||
make-text-input-field
|
||||
make-hidden-input-field
|
||||
make-password-input-field
|
||||
make-number-input-field
|
||||
make-textarea-input-field
|
||||
make-select-input-field
|
||||
make-checkbox-input-field
|
||||
make-radio-input-fields
|
||||
|
||||
make-submit-button
|
||||
make-reset-button
|
||||
make-image-button
|
||||
input-field-value
|
||||
raw-input-field-value
|
||||
input-field-binding
|
||||
|
||||
make-address
|
||||
make-annotated-address
|
||||
|
||||
returned-via
|
||||
returned-via?
|
||||
|
||||
(case-returned-via :syntax)
|
||||
|
||||
make-callback
|
||||
|
||||
my-session-id
|
||||
my-continuation-id
|
||||
my-ids
|
||||
|
||||
surflet-form-rules
|
||||
default-rules
|
||||
url-rule
|
||||
plain-html-rule)))
|
||||
|
||||
;; THE interface that SUrflets use.
|
||||
(define-interface surflet-interface
|
||||
(export main)) ; MAIN gets one parameter, the REQUEST
|
||||
|
|
@ -229,8 +170,119 @@
|
|||
rt-structure-binding
|
||||
load-structure))
|
||||
|
||||
;; With the help of TYPED-OPTIONALS you can define a function
|
||||
;; like (make-submit-button [string] args)
|
||||
(define-interface typed-optionals-interface
|
||||
(export typed-optionals
|
||||
(optionals :syntax)))
|
||||
|
||||
;;; Structures (GREP)
|
||||
;; Extensions/Exports to/from Olegs SSAX library
|
||||
(define-interface surflets/sxml-interface
|
||||
(export display-low-level-sxml
|
||||
sxml->string
|
||||
sxml-attribute?
|
||||
default-rule
|
||||
text-rule
|
||||
attribute-rule))
|
||||
|
||||
;; Input-fields as Scheme objects
|
||||
(define-interface surflets/input-fields-interface
|
||||
(export generate-input-field-name
|
||||
make-input-field
|
||||
make-higher-input-field
|
||||
make-text-input-field
|
||||
make-hidden-input-field
|
||||
make-password-input-field
|
||||
make-number-input-field
|
||||
make-textarea-input-field
|
||||
make-select-input-field
|
||||
make-checkbox-input-field
|
||||
make-radio-input-fields
|
||||
|
||||
make-submit-button
|
||||
make-reset-button
|
||||
make-image-button
|
||||
input-field-value
|
||||
raw-input-field-value
|
||||
input-field-binding
|
||||
input-field?))
|
||||
|
||||
;;; This is for surflets/surflet-sxml only:
|
||||
(define-interface surflets/input-fields/internal-interface
|
||||
(export *input-field-trigger*
|
||||
input-field-html-tree))
|
||||
|
||||
;; SUrflets' extensions to SXML
|
||||
(define-interface surflets/surflet-sxml-interface
|
||||
(export surflet-sxml->low-level-sxml
|
||||
surflet-sxml-rules
|
||||
surflet-form-rule
|
||||
default-rules
|
||||
plain-html-rule
|
||||
url-rule))
|
||||
|
||||
;; Access to session-id and continuation-id
|
||||
(define-interface surflets/ids-interface
|
||||
(export my-session-id
|
||||
my-continuation-id
|
||||
my-ids
|
||||
instance-session-id))
|
||||
|
||||
;; Some utilities
|
||||
(define-interface surflets/utilities-interface
|
||||
(export form-query-list
|
||||
rev-append
|
||||
make-callback
|
||||
generate-unique-name))
|
||||
|
||||
;; Intelligent Addresses
|
||||
(define-interface surflets/addresses-interface
|
||||
(export make-address
|
||||
make-annotated-address
|
||||
real-address-name
|
||||
real-address-annotated?))
|
||||
|
||||
;; Returned-via (dispatcher for input-fields and intelligent
|
||||
;; addresses)
|
||||
(define-interface surflets/returned-via-interface
|
||||
(export returned-via
|
||||
returned-via?
|
||||
(case-returned-via :syntax)))
|
||||
|
||||
;; Outdater denies access to outdated object
|
||||
(define-interface surflets/outdaters-interface
|
||||
(export make-outdater
|
||||
(if-outdated :syntax)
|
||||
show-outdated))
|
||||
|
||||
;; Access to form bindings in URL
|
||||
(define-interface surflets/bindings-interface
|
||||
(export get-bindings
|
||||
get-content-length
|
||||
extract-bindings
|
||||
extract-single-binding))
|
||||
|
||||
;; HTML-Extensions to send/suspend et al.
|
||||
(define-interface surflets/send-html-interface
|
||||
(export send-html/suspend
|
||||
send-html/finish
|
||||
send-html))
|
||||
|
||||
|
||||
;; Helping functions for surflets
|
||||
(define-interface surflets-interface
|
||||
(compound-interface
|
||||
surflet-handler/surflets-interface
|
||||
surflets/sxml-interface
|
||||
surflets/surflet-sxml-interface
|
||||
surflets/send-html-interface
|
||||
surflets/input-fields-interface
|
||||
surflets/addresses-interface
|
||||
surflets/returned-via-interface
|
||||
surflets/bindings-interface))
|
||||
|
||||
|
||||
;;; Structures
|
||||
;; structures from SUrflet Handler
|
||||
(define-structures
|
||||
((surflet-handler surflet-handler-interface)
|
||||
|
|
@ -267,25 +319,13 @@
|
|||
;; SUrflets library of helping functions
|
||||
(define-structure surflets surflets-interface
|
||||
(open surflet-handler/surflets
|
||||
surflet-handler/responses
|
||||
surflet-handler/admin
|
||||
httpd-responses ; STATUS-CODE
|
||||
surflet-requests ; HTTP-URL:SEARCH
|
||||
url ; REQUEST:URL
|
||||
(subset uri (escape-uri unescape-uri))
|
||||
parse-html-forms
|
||||
sxml-to-html ; SXML->HTML
|
||||
srfi-1 ; FILTER
|
||||
(subset srfi-13 (string-index))
|
||||
sxml-tree-trans
|
||||
define-record-types
|
||||
weak ;MAKE-WEAK-POINTER
|
||||
locks
|
||||
let-opt ;:OPTIONAL
|
||||
handle-fatal-error
|
||||
(subset sunet-utilities (get-header)) ; GET-HEADER
|
||||
scheme-with-scsh)
|
||||
(files surflets))
|
||||
surflets/sxml
|
||||
surflets/surflet-sxml
|
||||
surflets/send-html
|
||||
surflets/input-fields
|
||||
surflets/addresses
|
||||
surflets/returned-via
|
||||
surflets/bindings))
|
||||
|
||||
;; Shift-Reset
|
||||
(define-structure shift-reset shift-reset-interface
|
||||
|
|
@ -337,6 +377,118 @@
|
|||
httpd-requests)
|
||||
(files surflet-request))
|
||||
|
||||
;; With the help of TYPED-OPTIONALS you can define a function
|
||||
;; like (make-submit-button [string] args)
|
||||
(define-structure typed-optionals typed-optionals-interface
|
||||
(open scheme
|
||||
receiving ;receive
|
||||
srfi-23 ;error
|
||||
surflets/utilities ;rev-append
|
||||
(subset srfi-1 (make-list)))
|
||||
(files typed-optionals))
|
||||
|
||||
;; Extensions to Olegs SSAX library
|
||||
(define-structure surflets/sxml surflets/sxml-interface
|
||||
(open scheme-with-scsh ;string-ports
|
||||
(subset sxml-to-html (string->goodHTML entag))
|
||||
(subset sxml-tree-trans (pre-post-order)))
|
||||
(files sxml))
|
||||
|
||||
|
||||
;; Input fields as Scheme objects
|
||||
(define-structures
|
||||
((surflets/input-fields surflets/input-fields-interface)
|
||||
(surflets/input-fields/internal
|
||||
surflets/input-fields/internal-interface))
|
||||
(open scheme
|
||||
srfi-23 ;error
|
||||
(subset srfi-1 (filter))
|
||||
(subset let-opt (:optional))
|
||||
handle-fatal-error
|
||||
define-record-types
|
||||
(subset typed-optionals (optionals))
|
||||
surflets/sxml
|
||||
surflets/utilities ;rev-append,generate-unique-name
|
||||
)
|
||||
(files input-fields))
|
||||
|
||||
|
||||
;; Extensions to SXML for surflets
|
||||
(define-structure surflets/surflet-sxml surflets/surflet-sxml-interface
|
||||
(open scheme-with-scsh ;error,receive
|
||||
surflets/input-fields/internal
|
||||
surflets/sxml
|
||||
typed-optionals
|
||||
(subset sxml-tree-trans (pre-post-order)))
|
||||
(files surflet-sxml))
|
||||
|
||||
|
||||
;; Access to session-id and continuation-id
|
||||
(define-structure surflets/ids surflets/ids-interface
|
||||
(open scheme
|
||||
(subset surflet-requests (surflet-request-url))
|
||||
(subset srfi-1 (last))
|
||||
(subset surflet-handler/admin
|
||||
(instance-session-id
|
||||
resume-url-session-id
|
||||
resume-url-continuation-id
|
||||
resume-url-ids))
|
||||
(subset url (http-url-path)))
|
||||
(files ids))
|
||||
|
||||
|
||||
;; Some utilities
|
||||
(define-structure surflets/utilities surflets/utilities-interface
|
||||
(open scheme
|
||||
parse-html-forms
|
||||
(subset surflet-handler/surflets (send/suspend)))
|
||||
(files utilities))
|
||||
|
||||
|
||||
;; Intelligent Addresses
|
||||
(define-structure surflets/addresses surflets/addresses-interface
|
||||
(open scheme
|
||||
srfi-23 ;error
|
||||
(subset uri (escape-uri))
|
||||
define-record-types
|
||||
(subset surflets/utilities (generate-unique-name)))
|
||||
(files addresses))
|
||||
|
||||
|
||||
(define-structure surflets/returned-via surflets/returned-via-interface
|
||||
(open scheme
|
||||
surflets/input-fields
|
||||
surflets/addresses
|
||||
(subset uri (unescape-uri)))
|
||||
(files returned-via))
|
||||
|
||||
(define-structure surflets/outdaters surflets/outdaters-interface
|
||||
(open scheme
|
||||
define-record-types
|
||||
surflets/send-html)
|
||||
(files outdater))
|
||||
|
||||
(define-structure surflets/bindings surflets/bindings-interface
|
||||
(open scheme-with-scsh ;read-string,error
|
||||
locks
|
||||
weak ;weak pointers
|
||||
surflets/utilities ;form-query-list
|
||||
surflet-requests
|
||||
(subset url (http-url-search))
|
||||
(subset srfi-14 (char-set:digit))
|
||||
(subset srfi-13 (string-index))
|
||||
(subset srfi-1 (filter))
|
||||
(subset sunet-utilities (get-header)))
|
||||
(files bindings))
|
||||
|
||||
(define-structure surflets/send-html surflets/send-html-interface
|
||||
(open scheme
|
||||
(subset httpd-responses (status-code))
|
||||
surflet-handler/surflets
|
||||
surflets/sxml
|
||||
surflets/surflet-sxml)
|
||||
(files send-html))
|
||||
|
||||
;; These two are from Martin Gasbichler:
|
||||
(define-structure rt-module-language rt-module-language-interface
|
||||
(open scheme
|
||||
|
|
@ -383,3 +535,4 @@
|
|||
ensures-loaded
|
||||
package-commands-internal)
|
||||
(files rt-module))
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,47 @@
|
|||
|
||||
(define (returned-via return-object bindings)
|
||||
(if (input-field? return-object)
|
||||
(input-field-binding return-object bindings)
|
||||
;; We assume we have a return-address-object instead.
|
||||
(let ((address (return-object 'address)))
|
||||
(cond
|
||||
((assoc (real-address-name address) bindings) =>
|
||||
(lambda (pair)
|
||||
(if (real-address-annotated? address)
|
||||
(unescape-uri (cdr pair))
|
||||
#t)))
|
||||
(else #f)))))
|
||||
|
||||
;; It depends on the object, if returned-via returns only boolean
|
||||
;; values or string values as well. So let us have both names.
|
||||
(define returned-via? returned-via)
|
||||
|
||||
;; This is from Martin Gasbichler
|
||||
(define-syntax case-returned-via
|
||||
(syntax-rules (else =>)
|
||||
((case-returned-via (%bindings ...) clauses ...)
|
||||
(let ((bindings (%bindings ...)))
|
||||
(case-returned-via bindings clauses ...)))
|
||||
((case-returned-via bindings (else body ...))
|
||||
(begin body ...))
|
||||
((case-returned-via bindings
|
||||
((%return-object ...) => %proc))
|
||||
(cond ((or (returned-via %return-object bindings) ...)
|
||||
=> %proc)))
|
||||
((case-returned-via bindings
|
||||
((%return-object ...) %body ...))
|
||||
(if (or (returned-via? %return-object bindings) ...)
|
||||
(begin %body ...)))
|
||||
((case-returned-via bindings
|
||||
((%return-object ...) => %proc)
|
||||
%clause %clauses ...)
|
||||
(cond ((or (returned-via %return-object bindings) ...)
|
||||
=> %proc)
|
||||
(else
|
||||
(case-returned-via bindings %clause %clauses ...))))
|
||||
((case-returned-via bindings
|
||||
((%return-object ...) %body ...)
|
||||
%clause %clauses ...)
|
||||
(if (or (returned-via? %return-object bindings) ...)
|
||||
(begin %body ...)
|
||||
(case-returned-via bindings %clause %clauses ...)))))
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
;;; Allows sending of HTML represented in Oleg-like SXML-list instead
|
||||
;;; of pure string.
|
||||
;;; Copyright 2002,2003, Andreas Bernauer
|
||||
|
||||
(define (send-html/suspend html-tree-maker)
|
||||
(send/suspend
|
||||
(lambda (new-url)
|
||||
(make-usual-html-response
|
||||
(sxml->string (html-tree-maker new-url)
|
||||
surflet-sxml-rules)))))
|
||||
|
||||
(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
|
||||
(sxml->string html-tree surflet-sxml-rules))))
|
||||
|
||||
;; This is not for public, as we add the no-cache header that is
|
||||
;; needed for SUrflets.
|
||||
(define (make-usual-html-response html-string)
|
||||
(make-surflet-response
|
||||
(status-code ok)
|
||||
"text/html"
|
||||
'(("Cache-Control" . "no-cache"))
|
||||
html-string))
|
||||
|
||||
|
|
@ -0,0 +1,83 @@
|
|||
(define url-rule
|
||||
(cons 'url
|
||||
(lambda (tag uri . maybe-text)
|
||||
(list "<a href=\"" uri "\">"
|
||||
(if (null? maybe-text)
|
||||
uri
|
||||
maybe-text)
|
||||
"</a>"))))
|
||||
|
||||
(define plain-html-rule
|
||||
`(plain-html
|
||||
*preorder*
|
||||
. ,(lambda (tag . text) text)))
|
||||
|
||||
(define default-rules
|
||||
`(,attribute-rule
|
||||
,default-rule
|
||||
,text-rule
|
||||
,url-rule
|
||||
,plain-html-rule))
|
||||
|
||||
(define surflet-form-rule
|
||||
`(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? sxml-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
|
||||
((get GET) "GET")
|
||||
((post POST) "POST")
|
||||
((#f) "GET")
|
||||
(else
|
||||
(error "invalid method type" method)))))
|
||||
(surflet-sxml->low-level-sxml
|
||||
`(form (@ ((method ,real-method)
|
||||
(action ,k-url)
|
||||
,@(if attributes (cdr attributes) '())))
|
||||
,@elems))))
|
||||
|
||||
(define input-field-rule
|
||||
`(,*input-field-trigger*
|
||||
*preorder*
|
||||
. ,(lambda (trigger input-field)
|
||||
(surflet-sxml->low-level-sxml
|
||||
(input-field-html-tree input-field)))))
|
||||
|
||||
(define surflet-sxml-rules
|
||||
`(,@default-rules
|
||||
;; form contents:
|
||||
,input-field-rule
|
||||
,surflet-form-rule))
|
||||
|
||||
;; Low-Level-SXML is a list that can be understood by
|
||||
;; write-low-level-sxml. In contains only characters, strings, and
|
||||
;; thunks.
|
||||
(define (surflet-sxml->low-level-sxml sxml-tree)
|
||||
(pre-post-order sxml-tree surflet-sxml-rules))
|
||||
|
||||
;;; adapted from Oleg's SXML-to-HTML.scm
|
||||
;;; extended by additional port argument (see FORMATED-REPLY)
|
||||
;(define (surflet-xml->html port html-tree)
|
||||
; (let ((fragments (reformat html-tree)))
|
||||
; (cond
|
||||
; ((not port)
|
||||
; (call-with-string-output-port
|
||||
; (lambda (port)
|
||||
; (formated-reply port fragments))))
|
||||
; ((eq? port #t)
|
||||
; (formated-reply (current-output-port) fragments))
|
||||
; ((output-port? port)
|
||||
; (formated-reply port fragments))
|
||||
; (else
|
||||
; (error "Invalid port argument to FORMATED-REPLY" port)))))
|
||||
|
||||
|
||||
|
|
@ -1,748 +0,0 @@
|
|||
;; utilities for surflet
|
||||
;; Copyright 2002,2003, Andreas Bernauer
|
||||
;; Copyright 2003, Martin Gasbichler
|
||||
|
||||
(define (send-html/suspend html-tree-maker)
|
||||
(send/suspend
|
||||
(lambda (new-url)
|
||||
(make-usual-html-response
|
||||
(surflet-xml->html #f (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
|
||||
(surflet-xml->html #f html-tree))))
|
||||
|
||||
(define (make-usual-html-response html-string)
|
||||
(make-surflet-response
|
||||
(status-code ok)
|
||||
"text/html"
|
||||
'(("Cache-Control" . "no-cache"))
|
||||
html-string))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; 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 works only for GET and POST methods.
|
||||
|
||||
(define (form-query-list q)
|
||||
(if q
|
||||
(parse-html-form-query q)
|
||||
'()))
|
||||
|
||||
;; Bindings of POST requests can be read only once, since they are
|
||||
;; read from an input port. So we have to cache them, for the case of
|
||||
;; a later GET-BINDINGS call on the same POST request. The requests
|
||||
;; are referenced by a weak pointer. Thread-safe as all threads use
|
||||
;; the same lock.
|
||||
(define *POST-bindings-cache* '())
|
||||
(define *cache-lock* (make-lock))
|
||||
|
||||
(define (get-bindings surflet-request)
|
||||
(let ((request-method (surflet-request-method surflet-request)))
|
||||
(cond
|
||||
((string=? request-method "GET")
|
||||
(form-query-list (http-url-search
|
||||
(surflet-request-url surflet-request))))
|
||||
((string=? request-method "POST")
|
||||
(or (cached-bindings surflet-request)
|
||||
(let* ((content-length (get-content-length
|
||||
(surflet-request-headers surflet-request)))
|
||||
(input-port (surflet-request-input-port surflet-request))
|
||||
(form-data (read-string content-length input-port)))
|
||||
(let ((form-bindings (form-query-list form-data)))
|
||||
(obtain-lock *cache-lock*)
|
||||
(set! *POST-bindings-cache* (cons (cons (make-weak-pointer surflet-request)
|
||||
form-bindings)
|
||||
*POST-bindings-cache*))
|
||||
(release-lock *cache-lock*)
|
||||
form-bindings))))
|
||||
(else
|
||||
(error "unsupported request type")))))
|
||||
|
||||
;; Looking up, if we have cached this request. While going through the
|
||||
;; list, we remove entries to request objects, that are no longer
|
||||
;; valid. Expecting a call for an uncached request every now and then,
|
||||
;; it is guaranteed, that the list is cleaned up every now and
|
||||
;; then. The cache is a list of pairs
|
||||
;;; (surflet-request . computed-binding)
|
||||
(define (cached-bindings surflet-request)
|
||||
(obtain-lock *cache-lock*)
|
||||
(let ((result
|
||||
(let loop ((cache *POST-bindings-cache*))
|
||||
(if (null? cache)
|
||||
#f ; no such request cached
|
||||
(let* ((head (car cache))
|
||||
(s-req (weak-pointer-ref (car head))))
|
||||
(if s-req
|
||||
(if (eq? s-req surflet-request)
|
||||
(cdar cache) ; request is cached
|
||||
(loop (cdr cache))) ; request isn't cached
|
||||
(begin
|
||||
;; request object is gone ==> remove it from list
|
||||
(set! cache (cdr cache))
|
||||
(loop cache))))))))
|
||||
(release-lock *cache-lock*)
|
||||
result))
|
||||
|
||||
|
||||
;; Will be needed when we handle POST requests.
|
||||
(define (get-content-length headers)
|
||||
(cond ((get-header headers 'content-length) =>
|
||||
;; adopted from httpd/cgi-server.scm
|
||||
(lambda (content-length) ; Skip initial whitespace (& other non-digits).
|
||||
(let ((first-digit (string-index content-length char-set:digit))
|
||||
(content-length-len (string-length content-length)))
|
||||
(if first-digit
|
||||
(string->number (substring content-length first-digit
|
||||
content-length-len))
|
||||
;; (status-code bad-request) req
|
||||
(error "Illegal `Content-length:' header.")))))
|
||||
(else
|
||||
(error "No Content-length specified for POST data."))))
|
||||
|
||||
(define (extract-bindings key bindings)
|
||||
(let ((key (if (symbol? key) (symbol->string key) key)))
|
||||
(map cdr
|
||||
(filter (lambda (binding)
|
||||
(equal? (car binding) key))
|
||||
bindings))))
|
||||
|
||||
(define (extract-single-binding key bindings)
|
||||
(let ((key-bindings (extract-bindings key bindings)))
|
||||
(if (= 1 (length key-bindings))
|
||||
(car 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)
|
||||
(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 (surflet-xml->html port html-tree)
|
||||
(let ((fragments (reformat html-tree)))
|
||||
(cond
|
||||
((not port)
|
||||
(call-with-string-output-port
|
||||
(lambda (port)
|
||||
(formated-reply port fragments))))
|
||||
((eq? port #t)
|
||||
(formated-reply (current-output-port) fragments))
|
||||
((output-port? port)
|
||||
(formated-reply port fragments))
|
||||
(else
|
||||
(error "In surflet-xml->html: invalid port argument to FORMATED-REPLY"
|
||||
port)))))
|
||||
|
||||
(define (reformat html-tree)
|
||||
(pre-post-order
|
||||
html-tree
|
||||
`(,@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
|
||||
((get GET) "GET")
|
||||
((post POST) "POST")
|
||||
((#f) "GET")
|
||||
(else
|
||||
(error "invalid method type" method)))))
|
||||
(reformat
|
||||
`(form (@ ((method ,real-method)
|
||||
(action ,k-url)
|
||||
,@(if attributes (cdr attributes) '())))
|
||||
,@elems))))
|
||||
|
||||
(define (xml-attribute? thing)
|
||||
(and (pair? thing)
|
||||
(eq? '@ (car thing))))
|
||||
|
||||
(define attribute-rule
|
||||
`(@ ; local override for attributes
|
||||
((*default*
|
||||
. ,(lambda (attr-key . value) (enattr attr-key value))))
|
||||
. ,(lambda (trigger . value) (list '@ value))))
|
||||
|
||||
;; Create attribution-value pair for inside of tags
|
||||
;; If the attribute has no value, value must be '()
|
||||
(define (enattr attr-key attr-value)
|
||||
(if (null? attr-value)
|
||||
(list #\space attr-key)
|
||||
(list #\space attr-key "=\"" attr-value #\")))
|
||||
|
||||
(define text-rule
|
||||
`(*text*
|
||||
. ,(lambda (trigger str)
|
||||
(if (string? str) (string->goodHTML str) str))))
|
||||
|
||||
(define url-rule
|
||||
(cons 'url
|
||||
(lambda (tag uri . maybe-text)
|
||||
(list "<a href=\"" uri "\">"
|
||||
(if (null? maybe-text)
|
||||
uri
|
||||
maybe-text)
|
||||
"</a>"))))
|
||||
|
||||
(define plain-html-rule
|
||||
`(plain-html
|
||||
*preorder*
|
||||
. ,(lambda (tag . text) text)))
|
||||
|
||||
(define default-rules
|
||||
`(,attribute-rule
|
||||
(*default*
|
||||
. ,(lambda (tag . elems) (apply (entag tag) elems)))
|
||||
,text-rule
|
||||
,url-rule
|
||||
,plain-html-rule))
|
||||
|
||||
(define (make-callback function)
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(let* ((req (send/suspend (lambda (new-url)
|
||||
(exit new-url)))))
|
||||
(function req)))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; outdater
|
||||
|
||||
(define-record-type outdater :outdater
|
||||
(real-make-outdater outdated?)
|
||||
outdater?
|
||||
(outdated? outdater-outdated? set-outdater-outdated?!))
|
||||
|
||||
(define (make-outdater)
|
||||
(real-make-outdater #f))
|
||||
|
||||
(define-syntax if-outdated
|
||||
(syntax-rules ()
|
||||
((if-outdated outdater consequence alternative)
|
||||
(if (outdater-outdated? outdater)
|
||||
consequence
|
||||
(begin
|
||||
(set-outdater-outdated?! outdater #t)
|
||||
alternative)))))
|
||||
|
||||
(define (show-outdated url)
|
||||
(send-html
|
||||
`(html (title "Outdated Data")
|
||||
(body (h1 "Outdated Data")
|
||||
(p "The page or action you requested relies on outdated data.")
|
||||
,(if url
|
||||
`(p "Try to "
|
||||
(url ,url "reload")
|
||||
" the page to get current data.")
|
||||
'())))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; input-fields
|
||||
;;; defines input-fields for surflets
|
||||
|
||||
;; get-bindings: Transformer will get all bindings of request, not
|
||||
;; only the one concerning the input-field.
|
||||
(define-record-type input-field :input-field
|
||||
(real-make-input-field name transformer html-tree get-bindings?)
|
||||
real-input-field?
|
||||
(name input-field-name)
|
||||
(transformer input-field-transformer)
|
||||
(attributes input-field-attributes)
|
||||
(html-tree input-field-html-tree)
|
||||
(get-bindings? input-field-get-bindings?))
|
||||
|
||||
(define-record-discloser :input-field
|
||||
(lambda (input-field)
|
||||
(list 'input-field
|
||||
(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
|
||||
;; is a real input-field.
|
||||
(define (input-field? input-field)
|
||||
(and (pair? input-field)
|
||||
(eq? *input-field-trigger* (car input-field))
|
||||
(real-input-field? (cadr input-field))))
|
||||
|
||||
;; FIXME: consider creating small names
|
||||
(define generate-unique-name
|
||||
(let ((id 0))
|
||||
(lambda (type-string)
|
||||
(set! id (+ 1 id))
|
||||
(string-append type-string (number->string id)))))
|
||||
(define generate-input-field-name generate-unique-name)
|
||||
|
||||
(define identity (lambda (a) a))
|
||||
|
||||
;; 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)))
|
||||
|
||||
(define (make-higher-input-field transformer html-tree)
|
||||
(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
|
||||
;; list as got by procedure call. TYPED-OPTIONALS returns two values:
|
||||
;; a list of the same length as PRED-LIST and a list containing the
|
||||
;; left arguments that did not fit the predicates.
|
||||
;;
|
||||
;; With the help of TYPED-OPTIONALS you can define a function
|
||||
;; like `make-submit-button [string] [further-attributes]' this way:
|
||||
;; (define (make-submit-button . args)
|
||||
;; (receive (params rest-args)
|
||||
;; (prefix-optionals (list string? xml-attribute?) args)
|
||||
;; (if (pair? rest-args)
|
||||
;; (error "too many arguments to make-submit-button))
|
||||
;; (let ((value (first params))
|
||||
;; (attributes (second params)))
|
||||
;; ...))))
|
||||
;;
|
||||
(define (typed-optionals pred-list args)
|
||||
(let loop ((results '())
|
||||
(pred-list pred-list)
|
||||
(args args))
|
||||
(cond
|
||||
((null? pred-list)
|
||||
(values (reverse results) args))
|
||||
((null? args)
|
||||
(values (rev-append results (make-list (length pred-list) #f)) '()))
|
||||
(((car pred-list) (car args))
|
||||
(loop (cons (car args) results)
|
||||
(cdr pred-list)
|
||||
(cdr args)))
|
||||
(else
|
||||
(loop (cons #f results)
|
||||
(cdr pred-list)
|
||||
args)))))
|
||||
|
||||
|
||||
(define-syntax optionals
|
||||
(lambda (exp rename compare)
|
||||
(let ((%receive (rename 'receive))
|
||||
(%typed-optionals (rename 'typed-optionals))
|
||||
(%list (rename 'list))
|
||||
(%if (rename 'if))
|
||||
(%pair? (rename 'pair?))
|
||||
(%error (rename 'error))
|
||||
(%let (rename 'let))
|
||||
(%list-ref (rename 'list-ref))
|
||||
|
||||
(args (cadr exp))
|
||||
(var-list (caddr exp))
|
||||
(body (cadddr exp)))
|
||||
`(,%receive (params rest-args)
|
||||
(,%typed-optionals (,%list ,@(map cadr var-list)) ,args)
|
||||
(,%if (pair? rest-args)
|
||||
(,%error "optionals: too many arguments and/or argument type mismatch"
|
||||
rest-args)
|
||||
(,%let (,@(let loop ((counter 0)
|
||||
(var-list var-list))
|
||||
(if (null? var-list)
|
||||
'()
|
||||
(cons (cons (caar var-list) `((,%list-ref params ,counter)))
|
||||
(loop (+ 1 counter)
|
||||
(cdr var-list))))))
|
||||
,body))))))
|
||||
|
||||
;; from uri.scm
|
||||
(define (rev-append a b) ; (append (reverse a) b)
|
||||
(let rev-app ((a a) (b b)) ; Should be defined in a list-proc
|
||||
(if (pair? a) ; package, not here.
|
||||
(rev-app (cdr a) (cons (car a) b))
|
||||
b)))
|
||||
|
||||
(define (make-text-input-field . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "text")))
|
||||
(optionals maybe-further-attributes
|
||||
((default-text string?)
|
||||
(attributes xml-attribute?))
|
||||
(make-input-field name
|
||||
identity
|
||||
`(input (@ (type "text")
|
||||
(name ,name)
|
||||
,(and default-text `(value ,default-text))
|
||||
;; this will insert a list, but
|
||||
;; XML->HTML doesn't care about it
|
||||
,(and attributes (cdr attributes))
|
||||
))))))
|
||||
|
||||
(define make-number-input-field
|
||||
(let ((number-input-field-transformer
|
||||
(lambda (string)
|
||||
(or (string->number string)
|
||||
(error "wrong type")))
|
||||
))
|
||||
(lambda maybe-further-attributes
|
||||
(let ((name (generate-input-field-name "number")))
|
||||
(optionals maybe-further-attributes
|
||||
((default (lambda (a) (or (number? a)
|
||||
(string-or-symbol? a))))
|
||||
(attributes xml-attribute?))
|
||||
(make-input-field
|
||||
name
|
||||
number-input-field-transformer
|
||||
`(input (@ (type "text")
|
||||
(name ,name)
|
||||
,(and default `(value ,default))
|
||||
,(and attributes (cdr attributes))))))))))
|
||||
|
||||
(define (make-password-input-field . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "password")))
|
||||
(optionals maybe-further-attributes
|
||||
((attributes xml-attribute?))
|
||||
(make-input-field
|
||||
name
|
||||
identity
|
||||
`(input (@ (type "password")
|
||||
(name ,name)
|
||||
,(and attributes (cdr attributes))))))))
|
||||
|
||||
(define (make-textarea-input-field . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "textarea")))
|
||||
(optionals maybe-further-attributes
|
||||
((default-text string?)
|
||||
(attributes xml-attribute?))
|
||||
(make-input-field
|
||||
name
|
||||
identity
|
||||
`(textarea (@ (type "textarea")
|
||||
(name ,name)
|
||||
,(and attributes (cdr attributes)))
|
||||
,(and default-text))))))
|
||||
|
||||
;(make-select-input-fields '("this" "that" "those") '(@ ((id "sushi"))))
|
||||
;(make-select-input-fields '("this" ("that" '(@ (selected))) "those"))
|
||||
;; dropdown: (size 1)
|
||||
;; multiple choice: (multiple)
|
||||
;; preselected option: (selected)
|
||||
;; changed return value: (value new-value)
|
||||
;; returns a select input field with several options
|
||||
(define make-select-input-field
|
||||
(let ((make-multiple-transformer
|
||||
(lambda (name)
|
||||
(lambda (bindings)
|
||||
(map cdr
|
||||
(filter (lambda (binding)
|
||||
(equal? (car binding) name))
|
||||
bindings))))))
|
||||
|
||||
(lambda (options . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((multiple? boolean?)
|
||||
(attributes xml-attribute?))
|
||||
(let* ((name (generate-input-field-name "select"))
|
||||
(sxml-options
|
||||
(map (lambda (option)
|
||||
(cond
|
||||
((string-or-symbol? option)
|
||||
(list 'option option))
|
||||
((list? option)
|
||||
(cond
|
||||
((null? (cdr option))
|
||||
`(option ,option))
|
||||
((xml-attribute? (cdr option)) ; w/attribs?
|
||||
`(option ,(cdr option) ,(car option)))
|
||||
(else
|
||||
(error "not an attribute" (cdr option)))))
|
||||
(else
|
||||
(error "not an option" option))))
|
||||
options))
|
||||
(sxml `(select (@ ((name ,name)
|
||||
,(if multiple? '(multiple) '())
|
||||
,(and attributes (cdr attributes))))
|
||||
#\newline
|
||||
,sxml-options)))
|
||||
(if multiple?
|
||||
(make-higher-input-field (make-multiple-transformer name) sxml)
|
||||
(make-input-field name identity sxml)))))))
|
||||
|
||||
;; returns a *list* of radio buttons
|
||||
(define (make-radio-input-fields values . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "radio")))
|
||||
(optionals maybe-further-attributes
|
||||
((attributes xml-attribute?))
|
||||
(map (lambda (value)
|
||||
(let ((value-value (if (pair? value) (car value) value))
|
||||
(value-attributes (if (pair? value)
|
||||
(if (xml-attribute? (cdr value))
|
||||
(cddr value)
|
||||
(error "not an attribute" cdr value))
|
||||
#f)))
|
||||
(make-input-field
|
||||
name
|
||||
(lambda (select)
|
||||
select)
|
||||
`(input (@ ((type "radio")
|
||||
(name ,name)
|
||||
(value ,value-value)
|
||||
,(and value-attributes)
|
||||
,(and attributes (cdr attributes))))))))
|
||||
values))))
|
||||
|
||||
;; returns a checkbox input field
|
||||
(define (make-checkbox-input-field . maybe-further-attributes)
|
||||
(let* ((name (generate-input-field-name "checkbox")))
|
||||
(optionals maybe-further-attributes
|
||||
((checked? boolean?)
|
||||
(value (lambda (a) (or (string? a)
|
||||
(number? a)
|
||||
(symbol? a))))
|
||||
(attributes xml-attribute?))
|
||||
(make-input-field
|
||||
name
|
||||
(lambda (value)
|
||||
(or (string=? value "on")
|
||||
value))
|
||||
`(input (@ ((type "checkbox")
|
||||
(name ,name)
|
||||
,(if value `(value ,value) '())
|
||||
,(if checked? '(checked) '())
|
||||
,(and attributes (cdr attributes)))))))))
|
||||
|
||||
|
||||
(define (make-hidden-input-field value . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "hidden")))
|
||||
(optionals maybe-further-attributes
|
||||
((attributes xml-attribute?))
|
||||
(make-input-field name
|
||||
identity
|
||||
`(input (@ (type "hidden")
|
||||
(name ,name)
|
||||
(value ,value)
|
||||
,(and attributes (cdr attributes))))))))
|
||||
|
||||
(define (make-button type name button-caption attributes)
|
||||
(make-input-field name
|
||||
identity
|
||||
`(input (@ (type ,type)
|
||||
(name ,name)
|
||||
,(and button-caption `(value ,button-caption))
|
||||
,(and attributes (cdr attributes))))))
|
||||
|
||||
(define (string-or-symbol? a)
|
||||
(or (string? a)
|
||||
(symbol? a)))
|
||||
|
||||
(define (make-submit-button . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((button-caption string-or-symbol?)
|
||||
(attributes xml-attribute?))
|
||||
(make-button "submit" (generate-input-field-name "submit")
|
||||
button-caption attributes)))
|
||||
|
||||
(define (make-reset-button . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((button-caption string-or-symbol?)
|
||||
(attributes xml-attribute?))
|
||||
(make-button "reset" (generate-input-field-name "reset")
|
||||
button-caption attributes)))
|
||||
|
||||
(define (make-image-button image-source . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((attributes xml-attribute?))
|
||||
(make-button "image" (generate-input-field-name "imgbtn")
|
||||
#f `(@ (src ,image-source)
|
||||
,@(if attributes (cdr attributes) '())))))
|
||||
|
||||
;; <input-field>: '(input-field . <real-input-field>)
|
||||
;; <real-input-field>: #{Input-field "name"}
|
||||
(define (raw-input-field-value input-field bindings)
|
||||
(let ((input-field (cadr input-field)))
|
||||
(cond
|
||||
((input-field-get-bindings? input-field)
|
||||
((input-field-transformer input-field) bindings))
|
||||
((real-input-field-binding input-field bindings) =>
|
||||
(lambda (binding)
|
||||
((input-field-transformer input-field) (cdr binding))))
|
||||
(else
|
||||
(error "no such input-field" input-field bindings)))))
|
||||
|
||||
;; Trys to get a value for INPUT-FIELD in BINDINGS. If this fails
|
||||
;; (i.e. RAW-INPUT-FIELD-VALUE returns an error), the default-value is
|
||||
;; returned. The default-value defaults to #f. NOTE: If you do this
|
||||
;; with input-fields whose valid values may be the same as the default
|
||||
;; value, you cannot determine by the result if there was such a value
|
||||
;; or not. Keep in mind, that RAW-INPUT-FIELD-VALUE returns also an
|
||||
;; error, if there was not such an input field. This makes
|
||||
;; INPUT-FIELD-VALUE working with checkbox input fields because they
|
||||
;; miss if they are not checked.
|
||||
(define (input-field-value input-field bindings . maybe-default)
|
||||
(let ((default (:optional maybe-default #f)))
|
||||
(with-fatal-error-handler
|
||||
(lambda (condition more)
|
||||
default)
|
||||
(raw-input-field-value input-field bindings))))
|
||||
|
||||
(define (real-input-field-binding input-field bindings)
|
||||
(assoc (input-field-name input-field) bindings))
|
||||
|
||||
(define (input-field-binding input-field bindings)
|
||||
(real-input-field-binding (cadr input-field) bindings))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; return address
|
||||
|
||||
;; generates an unique return-addres
|
||||
;; may be used like
|
||||
;; (let ((address (make-address)))
|
||||
;; (send-html/suspend
|
||||
;; (lambda (new-url)
|
||||
;; ...
|
||||
;; (url (address new-url) "Click here to get more")...)
|
||||
|
||||
(define-record-type address :address
|
||||
(really-make-address name annotated?)
|
||||
(name address-name)
|
||||
(annotated? address-annotated?))
|
||||
|
||||
(define (make-address)
|
||||
(let ((address (really-make-address
|
||||
(generate-unique-name "return") #f)))
|
||||
(lambda (message)
|
||||
(cond
|
||||
((string? message)
|
||||
(string-append message "?" (address-name address) "="))
|
||||
((eq? message 'address)
|
||||
address)
|
||||
(else
|
||||
(error "address: unknown message/bad argument"
|
||||
message (address-name address)))))))
|
||||
|
||||
(define (make-annotated-address)
|
||||
(let ((address (really-make-address
|
||||
(generate-unique-name "return")
|
||||
#t)))
|
||||
(lambda (message . annotation)
|
||||
(cond
|
||||
((and (string? message)
|
||||
(<= (length annotation) 1))
|
||||
(let ((escaped-annotation
|
||||
(if (null? annotation)
|
||||
""
|
||||
(escape-uri (car annotation)))))
|
||||
(string-append message "?" (address-name address)
|
||||
"=" escaped-annotation)))
|
||||
((eq? message 'address)
|
||||
address)
|
||||
(else
|
||||
(error "annotated-address: unknown message/bad argument(s)"
|
||||
message (address-name address)))))))
|
||||
|
||||
(define (returned-via return-object bindings)
|
||||
(if (input-field? return-object)
|
||||
(input-field-binding return-object bindings)
|
||||
;; We assume we have a return-address-object instead.
|
||||
(let ((address (return-object 'address)))
|
||||
(cond
|
||||
((assoc (address-name address) bindings) =>
|
||||
(lambda (pair)
|
||||
(if (address-annotated? address)
|
||||
(unescape-uri (cdr pair))
|
||||
#t)))
|
||||
(else #f)))))
|
||||
|
||||
;; It depends on the object, if returned-via returns only boolean
|
||||
;; values or string values as well. So let us have both names.
|
||||
(define returned-via? returned-via)
|
||||
|
||||
(define (surflet-file-name req)
|
||||
(last (http-url-path (surflet-request-url req))))
|
||||
|
||||
;; This works for all requests except for the initial one. For the
|
||||
;; initial one (main's arg) think about using instance-session-id.
|
||||
(define (my-session-id req)
|
||||
(resume-url-session-id (surflet-file-name req)))
|
||||
|
||||
;; This works for all requests except for the initial one: we don't
|
||||
;; have a continuation at this time.
|
||||
(define (my-continuation-id req)
|
||||
(resume-url-continuation-id (surflet-file-name req)))
|
||||
|
||||
;; Returns two values: session-id and continuation-id. The
|
||||
;; restrictions from my-session-id and my-continuation-id apply here
|
||||
;; as well.
|
||||
(define (my-ids req)
|
||||
(resume-url-ids (surflet-file-name req)))
|
||||
|
||||
;; This is from Martin Gasbichler
|
||||
(define-syntax case-returned-via
|
||||
(syntax-rules (else =>)
|
||||
((case-returned-via (%bindings ...) clauses ...)
|
||||
(let ((bindings (%bindings ...)))
|
||||
(case-returned-via bindings clauses ...)))
|
||||
((case-returned-via bindings (else body ...))
|
||||
(begin body ...))
|
||||
((case-returned-via bindings
|
||||
((%return-object ...) => %proc))
|
||||
(cond ((or (returned-via %return-object bindings) ...)
|
||||
=> %proc)))
|
||||
((case-returned-via bindings
|
||||
((%return-object ...) %body ...))
|
||||
(if (or (returned-via? %return-object bindings) ...)
|
||||
(begin %body ...)))
|
||||
((case-returned-via bindings
|
||||
((%return-object ...) => %proc)
|
||||
%clause %clauses ...)
|
||||
(cond ((or (returned-via %return-object bindings) ...)
|
||||
=> %proc)
|
||||
(else
|
||||
(case-returned-via bindings %clause %clauses ...))))
|
||||
((case-returned-via bindings
|
||||
((%return-object ...) %body ...)
|
||||
%clause %clauses ...)
|
||||
(if (or (returned-via? %return-object bindings) ...)
|
||||
(begin %body ...)
|
||||
(case-returned-via bindings %clause %clauses ...)))))
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
;;; Copyright 2002, 2003 Andreas Bernauer
|
||||
|
||||
;;; adapted from Oleg's SXML-tree-trans.scm SRV:send-reply
|
||||
;;; extended by port argument
|
||||
;;; #t: current-output-port
|
||||
;;; #f: string
|
||||
;;; port: port
|
||||
;;; else: error
|
||||
;; Displays low-level-sxml on the port. Low-level-sxml contains only
|
||||
;; strings, characters and thunks. '() and #f are ignored.
|
||||
(define (display-low-level-sxml fragments port)
|
||||
(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)))))
|
||||
|
||||
;; Gives you a string representing the HTML of the already reformatted
|
||||
;; SXML-TREE.
|
||||
(define (sxml->string sxml-tree rules)
|
||||
(call-with-string-output-port
|
||||
(lambda (port)
|
||||
(display-low-level-sxml
|
||||
(pre-post-order sxml-tree rules)
|
||||
port))))
|
||||
|
||||
;; Predicate for attributes in sxml.
|
||||
(define (sxml-attribute? thing)
|
||||
(and (pair? thing)
|
||||
(eq? '@ (car thing))))
|
||||
|
||||
|
||||
;; Default rule: Creates leading and trailing tag and encloses the
|
||||
;; attributes.
|
||||
(define default-rule
|
||||
`(*default*
|
||||
. ,(lambda (tag . elems) (apply (entag tag) elems))))
|
||||
|
||||
;; Just displays the string, except that some characters are escaped.
|
||||
(define text-rule
|
||||
`(*text*
|
||||
. ,(lambda (trigger str)
|
||||
(if (string? str) (string->goodHTML str) str))))
|
||||
|
||||
;; Rule for attribution: creates an attribute like "selected" or
|
||||
;; "color="red""
|
||||
(define attribute-rule
|
||||
`(@ ; local override for attributes
|
||||
((*default*
|
||||
. ,(lambda (attr-key . value) (enattr attr-key value))))
|
||||
. ,(lambda (trigger . value) (list '@ value))))
|
||||
|
||||
;; Create attribution-value pair for inside of tags
|
||||
;; If the attribute has no value, value must be '()
|
||||
(define (enattr attr-key attr-value)
|
||||
(if (null? attr-value)
|
||||
(list #\space attr-key)
|
||||
(list #\space attr-key "=\"" attr-value #\")))
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
;; PRED-LIST contains list of predicates that recognizes optional
|
||||
;; leading parameters. FURTHER-ATTRIBUTES is the optional parameter
|
||||
;; list as got by procedure call. TYPED-OPTIONALS returns two values:
|
||||
;; a list of the same length as PRED-LIST and a list containing the
|
||||
;; left arguments that did not fit the predicates.
|
||||
;;
|
||||
;; With the help of TYPED-OPTIONALS you can define a function
|
||||
;; like `make-submit-button [string] [further-attributes]' this way:
|
||||
;; (define (make-submit-button . args)
|
||||
;; (receive (params rest-args)
|
||||
;; (prefix-optionals (list string? xml-attribute?) args)
|
||||
;; (if (pair? rest-args)
|
||||
;; (error "too many arguments to make-submit-button))
|
||||
;; (let ((value (first params))
|
||||
;; (attributes (second params)))
|
||||
;; ...))))
|
||||
;;
|
||||
(define (typed-optionals pred-list args)
|
||||
(let loop ((results '())
|
||||
(pred-list pred-list)
|
||||
(args args))
|
||||
(cond
|
||||
((null? pred-list)
|
||||
(values (reverse results) args))
|
||||
((null? args)
|
||||
(values (rev-append results (make-list (length pred-list) #f)) '()))
|
||||
(((car pred-list) (car args))
|
||||
(loop (cons (car args) results)
|
||||
(cdr pred-list)
|
||||
(cdr args)))
|
||||
(else
|
||||
(loop (cons #f results)
|
||||
(cdr pred-list)
|
||||
args)))))
|
||||
|
||||
|
||||
(define-syntax optionals
|
||||
(lambda (exp rename compare)
|
||||
(let ((%receive (rename 'receive))
|
||||
(%typed-optionals (rename 'typed-optionals))
|
||||
(%list (rename 'list))
|
||||
(%if (rename 'if))
|
||||
(%pair? (rename 'pair?))
|
||||
(%error (rename 'error))
|
||||
(%let (rename 'let))
|
||||
(%list-ref (rename 'list-ref))
|
||||
|
||||
(args (cadr exp))
|
||||
(var-list (caddr exp))
|
||||
(body (cadddr exp)))
|
||||
`(,%receive (params rest-args)
|
||||
(,%typed-optionals (,%list ,@(map cadr var-list)) ,args)
|
||||
(,%if (pair? rest-args)
|
||||
(,%error "optionals: too many arguments and/or argument type mismatch"
|
||||
rest-args)
|
||||
(,%let (,@(let loop ((counter 0)
|
||||
(var-list var-list))
|
||||
(if (null? var-list)
|
||||
'()
|
||||
(cons (cons (caar var-list) `((,%list-ref params ,counter)))
|
||||
(loop (+ 1 counter)
|
||||
(cdr var-list))))))
|
||||
,body))))))
|
||||
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
;; utilities for surflets
|
||||
;; Copyright 2002, 2003 Andreas Bernauer
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; from parse-html-forms (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 works only for GET and POST methods.
|
||||
|
||||
(define (form-query-list q)
|
||||
(if q
|
||||
(parse-html-form-query q)
|
||||
'()))
|
||||
|
||||
;; from uri.scm
|
||||
(define (rev-append a b) ; (append (reverse a) b)
|
||||
(let rev-app ((a a) (b b)) ; Should be defined in a list-proc
|
||||
(if (pair? a) ; package, not here.
|
||||
(rev-app (cdr a) (cons (car a) b))
|
||||
b)))
|
||||
|
||||
(define (make-callback function)
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(let* ((req (send/suspend (lambda (new-url)
|
||||
(exit new-url)))))
|
||||
(function req)))))
|
||||
|
||||
;; FIXME: consider creating small names
|
||||
(define generate-unique-name
|
||||
(let ((id 0))
|
||||
(lambda (type-string)
|
||||
(set! id (+ 1 id))
|
||||
(string-append type-string (number->string id)))))
|
||||
|
|
@ -1,5 +1,6 @@
|
|||
(define-structure surflet surflet-interface
|
||||
(open surflets
|
||||
surflets/utilities ;form-query-list
|
||||
surflet-requests
|
||||
httpd-responses
|
||||
url
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
(define-structure surflet surflet-interface
|
||||
(open scheme-with-scsh
|
||||
surflets
|
||||
surflets/utilities ;make-callback
|
||||
surflets/outdaters
|
||||
surflet-handler/admin
|
||||
httpd-responses
|
||||
handle-fatal-error
|
||||
|
|
|
|||
|
|
@ -1,6 +1,9 @@
|
|||
(define-structure surflet surflet-interface
|
||||
(open scheme-with-scsh
|
||||
surflets
|
||||
surflets/utilities ;make-callback
|
||||
surflets/outdaters
|
||||
surflets/ids
|
||||
surflet-handler/admin
|
||||
httpd-responses
|
||||
surflet-requests
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
(define-structure surflet surflet-interface
|
||||
(open surflets
|
||||
surflets/utilities ;make-callback
|
||||
surflet-requests
|
||||
handle-fatal-error
|
||||
let-opt
|
||||
|
|
|
|||
Loading…
Reference in New Issue