sunet/scheme/httpd/surflets/surflet-sxml.scm

96 lines
2.5 KiB
Scheme
Raw Normal View History

(define url-rule
`(url *preorder*
. ,(lambda (tag uri . maybe-text)
(surflet-sxml->low-level-sxml
`(a (@ (href ,uri))
,(if (null? maybe-text)
uri
maybe-text))))))
(define plain-html-rule
`(plain-html
*preorder*
. ,(lambda (tag . text) text)))
2003-04-16 08:19:44 -04:00
(define nbsp-rule
`(nbsp . ,(lambda (_) " ")))
(define comment-rule
`(*COMMENT* *preorder*
. ,(lambda (tag . elems)
`("<!-- "
,@elems
"-->"))))
(define default-rules
`(,attribute-rule
,default-rule
,text-rule
,comment-rule
,url-rule
2003-04-16 08:19:44 -04:00
,plain-html-rule
,nbsp-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
2003-04-16 08:19:44 -04:00
;; We need a real input-field for input-field-html-tree.
(input-field-html-tree (list trigger 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
2003-03-13 06:32:38 -05:00
;; display-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)))))