From ef819fa5815a7171b2b71d5e4fb52e8704514cf9 Mon Sep 17 00:00:00 2001
From: eknauel <eknauel>
Date: Mon, 10 Jul 2006 12:02:39 +0000
Subject: [PATCH] Add structure `surflets/send-xml' which provides
 `send-xml/finish' and `send-xml/suspend'.  These functions produce XML output
 rather than HTML.

---
 scheme/httpd/surflets/packages.scm | 12 +++++-
 scheme/httpd/surflets/send-xml.scm | 60 ++++++++++++++++++++++++++++++
 2 files changed, 71 insertions(+), 1 deletion(-)
 create mode 100644 scheme/httpd/surflets/send-xml.scm

diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm
index 7bda766..9d0d2da 100644
--- a/scheme/httpd/surflets/packages.scm
+++ b/scheme/httpd/surflets/packages.scm
@@ -383,7 +383,9 @@
 	  send-html/finish
 	  send-html))
 
-
+(define-interface surflets/send-xml-interface
+  (export send-xml/finish
+	  send-xml/suspend))
 
 ;; Helping functions for surflets (for basic user)
 (define-interface surflets-interface
@@ -451,6 +453,14 @@
 	surflets/returned-via
 	surflets/bindings))
 
+(define-structure surflets/send-xml surflets/send-xml-interface
+  (open scheme
+	surflets/sxml
+	surflets/my-sxml
+	surflet-handler/primitives
+	surflet-handler/responses)
+  (files send-xml))
+
 ;; SUrflets library for advanced users: make and use your own
 ;; conversion rules.
 (define-structure surflets/my-sxml surflets/my-sxml-interface
diff --git a/scheme/httpd/surflets/send-xml.scm b/scheme/httpd/surflets/send-xml.scm
new file mode 100644
index 0000000..62e7c57
--- /dev/null
+++ b/scheme/httpd/surflets/send-xml.scm
@@ -0,0 +1,60 @@
+(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))))