61 lines
1.4 KiB
Scheme
61 lines
1.4 KiB
Scheme
|
(define processing-instruction-rule
|
||
|
|
`(*PI* *preorder*
|
||
|
|
. ,(lambda (tag . elems)
|
||
|
|
`(,(string-append "<?" (symbol->string (car elems)) " ")
|
||
|
|
,@(cdr elems)
|
||
|
|
"?>"))))
|
||
|
|
|
||
|
|
(define doctype-rule
|
||
|
|
`(*DOCTYPE* *preorder*
|
||
|
|
. ,(lambda (content . more)
|
||
|
|
`("<!DOCTYPE " ,@more ">"))))
|
||
|
|
|
||
|
|
(define xml-default-rule
|
||
|
|
`(*default* .
|
||
|
|
,(lambda (tag . elems)
|
||
|
|
(apply (entag tag) elems))))
|
||
|
|
|
||
|
|
(define (entag tag)
|
||
|
|
(lambda elems
|
||
|
|
(if (and (pair? elems) (pair? (car elems)) (eq? '@ (caar elems)))
|
||
|
|
(list #\< tag (cdar elems)
|
||
|
|
(if (pair? (cdr elems)) (list #\> (cdr elems) "</" tag #\>)
|
||
|
|
"/>"))
|
||
|
|
(list #\< tag
|
||
|
|
(if (pair? elems) (list #\> elems "</" tag #\>) "/>")))))
|
||
|
|
|
||
|
|
(define comment-rule
|
||
|
|
`(*COMMENT* *preorder*
|
||
|
|
. ,(lambda (tag . elems)
|
||
|
|
`("<!-- " ,@elems "-->"))))
|
||
|
|
|
||
|
|
(define xml-rules
|
||
|
|
(list attribute-rule
|
||
|
|
xml-default-rule
|
||
|
|
processing-instruction-rule
|
||
|
|
doctype-rule
|
||
|
|
text-rule
|
||
|
|
comment-rule
|
||
|
|
url-rule
|
||
|
|
plain-html-rule
|
||
|
|
nbsp-rule))
|
||
|
|
|
||
|
|
(define (make-xml-reponse xml-string)
|
||
|
|
(make-surflet-response
|
||
|
|
(status-code ok)
|
||
|
|
"text/xml"
|
||
|
|
'(("Cache-Control" . "no-cache"))
|
||
|
|
xml-string))
|
||
|
|
|
||
|
|
(define (send-xml/suspend xml-tree-maker)
|
||
|
|
(send/suspend
|
||
|
|
(lambda (k-url)
|
||
|
|
(make-xml-reponse
|
||
|
|
(sxml->string (xml-tree-maker k-url)
|
||
|
|
xml-rules)))))
|
||
|
|
|
||
|
|
(define (send-xml/finish xml-tree)
|
||
|
|
(send
|
||
|
|
(make-xml-reponse
|
||
|
|
(sxml->string xml-tree xml-rules))))
|