+ 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 2003-03-10 16:29:32 +00:00
parent 87a4165f94
commit 3fc36e865e
17 changed files with 1034 additions and 827 deletions

View File

@ -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)))))))

View File

@ -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))))

View File

@ -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)))

View File

@ -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))

View File

@ -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.")
'())))))

View File

@ -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))

View File

@ -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 ...)))))

View File

@ -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))

View File

@ -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)))))

View File

@ -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 ...)))))

View File

@ -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 #\")))

View File

@ -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))))))

View File

@ -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)))))

View File

@ -1,5 +1,6 @@
(define-structure surflet surflet-interface
(open surflets
surflets/utilities ;form-query-list
surflet-requests
httpd-responses
url

View File

@ -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

View File

@ -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

View File

@ -1,5 +1,6 @@
(define-structure surflet surflet-interface
(open surflets
surflets/utilities ;make-callback
surflet-requests
handle-fatal-error
let-opt