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

renaming UTILTIES.SCM to SERVLETS.SCM and structure PLUGIN-UTILITIES to SERVLETS

This commit is contained in:
interp 2002-09-25 17:01:00 +00:00
parent c28d6cf153
commit 1abbed29f0
1 changed files with 0 additions and 258 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

258
scheme/httpd/surflets/utilities.scm
View File

@ -1,258 +0,0 @@
;; utilities for plugin (servlets)
;; 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 (extract-bindings bindings key)
(let ((key (if (symbol? key) (symbol->string key) key)))
(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))
(cdar 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
(pre-post-order html-tree
;; Universal transformation rules. Work for every HTML,
;; present and future
`(,@default-rules
(form *preorder* .
,(lambda (trigger call-back-function . elems)
(list "<form method=\"GET\" action=\"" call-back-function
(if (and (pair? elems) (pair? (car elems)) (eq? '@ (caar elems)))
(list (car elems) "\">\n" (parse-form-elems (cdr elems)) "</form>")
(list "\">\n" (parse-form-elems elems) "</form>"))))))
)))
(define (parse-form-elems elems)
(map (lambda (elem)
(if (input-field? elem)
(post-order (input-field-HTML-tree elem) default-rules)
(post-order elem default-rules)))
elems))
(define text-html-rule
`(*text* . ,(lambda (trigger str)
(if (string? str) (string->goodHTML str) str))))
(define default-rules
`((@ ; local override for attributes
((*default*
. ,(lambda (attr-key . value) ((enattr attr-key) value))))
. ,(lambda (trigger . value) (list '@ value)))
(*default* . ,(lambda (tag . elems) (apply (entag tag) elems)))
,text-html-rule
(URL . ,(lambda (tag URI text) (list "<a href=\"" URI "\">" text "</a>"))))
)
(define (make-callback function)
(call-with-current-continuation
(lambda (exit)
(let* ((req (send/suspend (lambda (new-url)
(exit new-url))))
(bindings (form-query (http-url:search (request:url req)))))
(function bindings)))))
(define-record-type input-field :input-field
(make-input-field name transformer HTML-tree)
input-field?
(name input-field-name)
(transformer input-field-transformer)
(attributes input-field-attributes)
(HTML-tree input-field-HTML-tree))
(define-record-discloser :input-field
(lambda (input-field)
(list 'input-field (input-field-name input-field))))
;; FIXME: consider creating small names
(define generate-input-field-name
(let ((id 0))
(lambda (type-string)
(set! id (+ 1 id))
(string-append type-string (number->string id)))))
(define identity (lambda (a) a))
(define (make-text-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "text")))
(make-input-field name
identity
`(input (@ (type "text")
(name ,name)
,@maybe-further-attributes)))))
(define (make-number-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "number")))
(make-input-field name
(lambda (string)
(or (string->number string)
(error "wrong type")))
`(input (@ (type "text")
(name ,name)
,@maybe-further-attributes)))))
(define (make-password-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "password")))
(make-input-field name
identity
`(input (@ (type "password")
(name ,name)
,@maybe-further-attributes)))))
(define (make-textarea-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "textarea"))
(default-text (if (and (pair? maybe-further-attributes)
(string? (car maybe-further-attributes)))
(car maybe-further-attributes)
'())))
(make-input-field name
identity
`(textarea (@ (type "textarea")
(name ,name)
,@maybe-further-attributes)
,default-text))))
(define (make-select-input-field options . maybe-further-attributes)
(let ((name (generate-input-field-name "select")))
(make-input-field name
(lambda (select)
select) ;FIXME[extension] refer to list elements
`(select (@ ((name ,name)
,@maybe-further-attributes))
#\newline
,@(map (lambda (option)
(if (pair? option) ; with attributes?
`(option (@ ,@(cdr option)) ,(car option))
`(option ,option)))
options)))))
;; in work
(define (make-radio-input-field values . maybe-further-attributes)
(let ((name (generate-input-field-name "radio")))
(make-input-field name
(lambda (select)
select) ;FIXME refer to list elements
(map (lambda (value)
`((input (@ ((type "radio")
(name ,name)
,@maybe-further-attributes
,(if (pair? value) ; with attributes?
(cdr value)
'())))) ;FIXME: add value field
,(if (pair? value) ; with attributes?
(car value)
value)))
values))))
(define (make-submit-button . maybe-further-attributes)
(if (and (pair? maybe-further-attributes)
(string? (car maybe-further-attributes)))
`(input (@ (type "submit")
(value ,(car maybe-further-attributes))
,@maybe-further-attributes))
`(input (@ (type "submit")
,@maybe-further-attributes))))
(define (input-field-value input-field bindings)
(cond
((assoc (input-field-name input-field) bindings) =>
(lambda (binding)
((input-field-transformer input-field) (cdr binding))))
(else
(error "no such input-field" input-field bindings))))
(define number-input-field (make-number-input-field))
(define test
`(html
(title "My Title")
(body
(p (URL "reset" "click here to reset"))
(p (form "return-URI" (table (tr (td "Enter a number ") (td ,number-input-field )))
,(make-submit-button))))))