569 lines
17 KiB
Scheme
569 lines
17 KiB
Scheme
;; utilities for servlet
|
|
;; Copyright 2002, Andreas Bernauer
|
|
|
|
(define (send-html/suspend html-tree-maker)
|
|
(send/suspend
|
|
(lambda (new-url)
|
|
(make-usual-html-response
|
|
(lambda (out options)
|
|
(servlet-XML->HTML out (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
|
|
(lambda (out options)
|
|
(servlet-XML->HTML out html-tree)))))
|
|
|
|
(define (make-usual-html-response writer-proc)
|
|
(make-response
|
|
http-status/ok
|
|
(status-code->text http-status/ok)
|
|
(time)
|
|
"text/html"
|
|
'()
|
|
(make-writer-body writer-proc)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; 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 only works for GET and POST methods.
|
|
|
|
(define form-query parse-html-form-query)
|
|
(define (get-bindings request)
|
|
(let ((request-method (request:method request)))
|
|
(cond
|
|
((string=? request-method "GET")
|
|
(form-query (http-url:search (request:url request))))
|
|
((string=? request-method "POST")
|
|
(let* ((content-length (get-content-length (request:headers request)))
|
|
(input-port (socket:inport (request:socket request)))
|
|
(form-data (read-string content-length input-port)))
|
|
(form-query form-data)))
|
|
(else
|
|
(error "unsupported request type")))))
|
|
|
|
;; 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))
|
|
;; http-status/bad-request req
|
|
`(error "Illegal `Content-length:' header.")))))
|
|
(else
|
|
(error "No Content-length specified for POST data."))))
|
|
|
|
(define (extract-bindings bindings key)
|
|
(let ((key (if (symbol? key) (symbol->string key) key)))
|
|
(map cdr
|
|
(filter (lambda (binding)
|
|
(equal? (car binding) key))
|
|
bindings))))
|
|
|
|
(define (extract-single-binding bindings key)
|
|
(let ((key-bindings (extract-bindings bindings key)))
|
|
(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)
|
|
(cond
|
|
((not port)
|
|
(call-with-string-output-port
|
|
(lambda (port)
|
|
(real-formated-reply port fragments))))
|
|
((eq? port #t)
|
|
(real-formated-reply (current-output-port) fragments))
|
|
((output-port? port)
|
|
(real-formated-reply port fragments))
|
|
(else
|
|
(error "invalid port argument to FORMATED-REPLY" port))))
|
|
|
|
(define (real-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 (servlet-XML->HTML out html-tree)
|
|
(formated-reply out
|
|
(reformat html-tree)))
|
|
|
|
(define (reformat html-tree)
|
|
(pre-post-order
|
|
html-tree
|
|
`(
|
|
;; Universal transformation rules. Works for every HTML,
|
|
;; present and future
|
|
,@default-rules
|
|
(input-field
|
|
*preorder*
|
|
. ,(lambda (trigger input-field)
|
|
(reformat (input-field-HTML-tree input-field))))
|
|
|
|
(servlet-form
|
|
;; Must do something to prevent the callback-function string to
|
|
;; be HTML escaped.
|
|
*preorder*
|
|
. ,(lambda (trigger call-back-function . elems)
|
|
(if (and (pair? elems)
|
|
(XML-attribute? (car elems)))
|
|
(make-servlet-form call-back-function (cdar elems) (cdr elems))
|
|
(make-servlet-form call-back-function'() elems)))))
|
|
))
|
|
|
|
(define (make-servlet-form call-back-function attributes elems)
|
|
`("<form" ,@(map (lambda (attribute-value)
|
|
((enattr (car attribute-value)) (cadr attribute-value)))
|
|
`((method "POST")
|
|
(action ,call-back-function)
|
|
,@attributes))
|
|
#\> #\newline
|
|
,(reformat elems)
|
|
"</form>"))
|
|
|
|
(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))))
|
|
|
|
(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 (pair? maybe-text)
|
|
maybe-text
|
|
URI)"</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 servlets
|
|
|
|
(define-record-type input-field :input-field
|
|
(real-make-input-field name transformer HTML-tree get-bindings?)
|
|
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))))
|
|
|
|
;; 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))
|
|
|
|
(define (make-input-field name transformer HTML-tree)
|
|
(list 'input-field (real-make-input-field name transformer HTML-tree #f)))
|
|
|
|
(define (make-upper-input-field transformer HTML-tree)
|
|
(list 'input-field (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")
|
|
(,%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)
|
|
(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? (cadr option)) ; w/attribs?
|
|
`(option ,(cadr 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-upper-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? (cadr value))
|
|
(cdadr value)
|
|
(error "not an attribute" cadr value))
|
|
#f)))
|
|
(make-input-field
|
|
name
|
|
(lambda (select)
|
|
select) ;FIXME refer to list elements
|
|
`(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
|
|
((value (lambda (a) (or (string? a)
|
|
(number? a)
|
|
(symbol? a))))
|
|
(attributes XML-attribute?))
|
|
(make-input-field
|
|
name
|
|
identity
|
|
`(input (@ ((type "checkbox")
|
|
(name ,name)
|
|
,(if value `(value ,value) '())
|
|
,(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 (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)))))
|
|
|
|
(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 (make-address)
|
|
(let ((name (generate-unique-name "return")))
|
|
(lambda (message)
|
|
(cond
|
|
((string? message)
|
|
(string-append message "?" name "="))
|
|
((eq? message 'name)
|
|
name)
|
|
(else ;maybe we want more later...
|
|
(error "unknown message" message name))))))
|
|
|
|
|
|
(define (returned-via? return-address bindings)
|
|
(assoc (return-address 'name) bindings))
|
|
|