+ 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-session-id
|
||||||
resume-url-continuation-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.
|
;; THE interface that SUrflets use.
|
||||||
(define-interface surflet-interface
|
(define-interface surflet-interface
|
||||||
(export main)) ; MAIN gets one parameter, the REQUEST
|
(export main)) ; MAIN gets one parameter, the REQUEST
|
||||||
|
|
@ -229,8 +170,119 @@
|
||||||
rt-structure-binding
|
rt-structure-binding
|
||||||
load-structure))
|
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
|
;; structures from SUrflet Handler
|
||||||
(define-structures
|
(define-structures
|
||||||
((surflet-handler surflet-handler-interface)
|
((surflet-handler surflet-handler-interface)
|
||||||
|
|
@ -267,25 +319,13 @@
|
||||||
;; SUrflets library of helping functions
|
;; SUrflets library of helping functions
|
||||||
(define-structure surflets surflets-interface
|
(define-structure surflets surflets-interface
|
||||||
(open surflet-handler/surflets
|
(open surflet-handler/surflets
|
||||||
surflet-handler/responses
|
surflets/sxml
|
||||||
surflet-handler/admin
|
surflets/surflet-sxml
|
||||||
httpd-responses ; STATUS-CODE
|
surflets/send-html
|
||||||
surflet-requests ; HTTP-URL:SEARCH
|
surflets/input-fields
|
||||||
url ; REQUEST:URL
|
surflets/addresses
|
||||||
(subset uri (escape-uri unescape-uri))
|
surflets/returned-via
|
||||||
parse-html-forms
|
surflets/bindings))
|
||||||
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))
|
|
||||||
|
|
||||||
;; Shift-Reset
|
;; Shift-Reset
|
||||||
(define-structure shift-reset shift-reset-interface
|
(define-structure shift-reset shift-reset-interface
|
||||||
|
|
@ -337,6 +377,118 @@
|
||||||
httpd-requests)
|
httpd-requests)
|
||||||
(files surflet-request))
|
(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:
|
;; These two are from Martin Gasbichler:
|
||||||
(define-structure rt-module-language rt-module-language-interface
|
(define-structure rt-module-language rt-module-language-interface
|
||||||
(open scheme
|
(open scheme
|
||||||
|
|
@ -383,3 +535,4 @@
|
||||||
ensures-loaded
|
ensures-loaded
|
||||||
package-commands-internal)
|
package-commands-internal)
|
||||||
(files rt-module))
|
(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
|
(define-structure surflet surflet-interface
|
||||||
(open surflets
|
(open surflets
|
||||||
|
surflets/utilities ;form-query-list
|
||||||
surflet-requests
|
surflet-requests
|
||||||
httpd-responses
|
httpd-responses
|
||||||
url
|
url
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,8 @@
|
||||||
(define-structure surflet surflet-interface
|
(define-structure surflet surflet-interface
|
||||||
(open scheme-with-scsh
|
(open scheme-with-scsh
|
||||||
surflets
|
surflets
|
||||||
|
surflets/utilities ;make-callback
|
||||||
|
surflets/outdaters
|
||||||
surflet-handler/admin
|
surflet-handler/admin
|
||||||
httpd-responses
|
httpd-responses
|
||||||
handle-fatal-error
|
handle-fatal-error
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,9 @@
|
||||||
(define-structure surflet surflet-interface
|
(define-structure surflet surflet-interface
|
||||||
(open scheme-with-scsh
|
(open scheme-with-scsh
|
||||||
surflets
|
surflets
|
||||||
|
surflets/utilities ;make-callback
|
||||||
|
surflets/outdaters
|
||||||
|
surflets/ids
|
||||||
surflet-handler/admin
|
surflet-handler/admin
|
||||||
httpd-responses
|
httpd-responses
|
||||||
surflet-requests
|
surflet-requests
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,6 @@
|
||||||
(define-structure surflet surflet-interface
|
(define-structure surflet surflet-interface
|
||||||
(open surflets
|
(open surflets
|
||||||
|
surflets/utilities ;make-callback
|
||||||
surflet-requests
|
surflet-requests
|
||||||
handle-fatal-error
|
handle-fatal-error
|
||||||
let-opt
|
let-opt
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue