adapt to new response philosophy (not tested yet)

scheme/httpd/info-gateway.scm

@@ -149,20 +149,24 @@
 	      (else
 	       (decline))))
 
-	   (if (not (v0.9-request? req))
-	       (begin
-		 (begin-http-header #t http-status/ok)
-		 (write-string "Content-type: text/html\r\n")
-		 (write-string "\r\n")))
+	   (make-response
+	    http-status/ok
+	    (status-code->text http-status/ok)
+	    (time)
+	    "text/html"
+	    '()
+	    (make-writer-body
+	     (lambda (out options)
 	   
 	       (receive (find-entry node-name) (parse-info-url (request:url req))
 		 (display-node node-name
 			       (file-finder find-entry)
-				  (referencer make-reference (request:url req))
-				  icon-name))
+			       (referencer make-reference (request:url req) out)
+			       icon-name
+			       out))
+	       (with-tag out address ()
+		 (write-string address out)))))))
 
-	   (with-tag #t address ()
-		     (write-string address))))
 	 (else (http-error http-status/method-not-allowed req)))))))
 
 (define split-header-line
@@ -219,23 +223,23 @@
 			     (values file node))
       (string-append "(" file ")" node))))
 
-(define (display-icon file alt)
-  (emit-tag #t 'img
+(define (display-icon file alt out)
+  (emit-tag out 'img
     (cons 'src file)
     (cons 'alt alt)
     (cons 'align "bottom")))
 	 
-(define (referencer make-reference old-entry)
+(define (referencer make-reference old-entry out)
   (lambda (file node-name label . maybe-icon)
     (receive (node-file node) (parse-node-name node-name)
       (let ((file (or node-file file)))
-	(with-tag #t a ((href (make-reference
+	(with-tag out a ((href (make-reference
 				old-entry
 				(escape-uri (unparse-node-name file node)))))
 	  (if (and (not (null? maybe-icon))
 		   (car maybe-icon))
-	      (display-icon (car maybe-icon) (cadr maybe-icon)))
-	  (emit-text label))))))
+	      (display-icon (car maybe-icon) (cadr maybe-icon) out))
+	  (emit-text label out))))))
 
 (define node-prologue (ascii->char 31))
 (define node-epilogue-regexp
@@ -256,30 +260,30 @@
 ;; Document title
 
 (define (display-title file node up previous next
-		       display-reference icon-name)
+		       display-reference icon-name out)
 
   (define (maybe-display-header header icon alt)
     (if header
 	(begin
 	  (newline)
-	  (with-tag #t b ()
+	  (with-tag out b ()
 	    (display-reference file header header icon alt)))))
 
-  (emit-title #t (string-append "Info Node: "
+  (emit-title out (string-append "Info Node: "
 				(unparse-node-name file node)))
-  (with-tag #t h1 ()
-	    (emit-tag #t 'img
+  (with-tag out h1 ()
+	    (emit-tag out 'img
 		      (cons 'src (icon-name 'info))
 		      (cons 'alt "Info Node")
 		      (cons 'align 'bottom))
-	    (write-string (unparse-node-name file node)))
-  (emit-tag #t 'hr)
+	    (write-string (unparse-node-name file node) out))
+  (emit-tag out 'hr)
   (maybe-display-header next (icon-name 'next) "[Next]")
   (maybe-display-header previous (icon-name 'previous) "[Previous]")
   (maybe-display-header up (icon-name 'up) "[Up]")
 	 
   (if (or next previous up)
-      (emit-tag #t 'hr)))
+      (emit-tag out 'hr)))
 
 ;; Text
 
@@ -311,7 +315,7 @@
 		    (loop (string-append line cr new-line) (- count 1))))))))))
 		    
 
-(define (display-xref xref file display-reference)
+(define (display-xref xref file display-reference out)
   (let* ((match (regexp-exec xref-regexp xref))
 	 (note (match:substring match 1))
 	 (node-name (match:substring match 2))
@@ -319,22 +323,22 @@
 	 (node-name (substring node-name
 			       (string-skip node-name char-set:whitespace)
 			       (string-length node-name))))
-    (emit-text "See ")
+    (emit-text "See " out)
     (display-reference file node-name note)))
 
 (define display-text
   (let ((split-xrefs (infix-splitter xref-regexp #f 'split)))
-    (lambda (line port file display-reference)
+    (lambda (line port file display-reference out)
       (let* ((line (complete-line line port))
 	     (components (split-xrefs line)))
 	;; in components, every 2nd element is a cross reference
 	;; also, it always has odd length or length zero
 	(if (not (null? components))
 	    (let loop ((components components))
-	      (emit-text (car components))
+	      (emit-text (car components) out)
 	      (if (not (null? (cdr components)))
 		  (begin
-		    (display-xref (cadr components) file display-reference)
+		    (display-xref (cadr components) file display-reference out)
 		    (loop (cddr components))))))
 	(newline)))))
 
@@ -353,7 +357,7 @@
 
 (define colon-split (char-splitter #\:))
 
-(define (display-menu-item-header line port file display-reference icon-name)
+(define (display-menu-item-header line port file display-reference icon-name out)
   (let ((menu-line-split (infix-splitter menu-item-regexp)))
     (receive (note rest) (colon-split (cadr (menu-line-split line)))
       (receive (node-name text)
@@ -367,24 +371,24 @@
 			 (match:substring match 2))))
 	   (else
 	    (info-gateway-error  "invalid menu item")))
-	(emit-tag #t 'dt)
+	(emit-tag out 'dt)
 	(display-reference file node-name note (icon-name 'menu) "*")
 	(newline)
 	(if (and (not (string=? "" text))
 		 (not (string=? "." text)))
 	    (begin
-	      (emit-tag #t 'dd)
-	      (display-text text port file display-reference)))))))
+	      (emit-tag out 'dd)
+	      (display-text text port file display-reference out)))))))
 
-(define (display-menu line port file display-reference icon-name)
-  (emit-close-tag #t 'pre)
+(define (display-menu line port file display-reference icon-name out)
+  (emit-close-tag out 'pre)
     
-  (with-tag #t dl ()
+  (with-tag out dl ()
     (let loop ((line line))
       (if (eof-object? line)
 	  (info-gateway-error "unexpected end of info file"))
 
-      (display-menu-item-header line port file display-reference icon-name)
+      (display-menu-item-header line port file display-reference icon-name out)
 
       (let finish-item-loop ()
 	(if (eof-object? line)
@@ -395,45 +399,48 @@
 	   ((or (eof-object? line)
 		(node-epilogue? line)
 		(string=? "" line))
-	    (emit-tag #t 'pre)
-	    (dispatch-line line port file display-reference icon-name))
+	    (emit-tag out 'pre)
+	    (dispatch-line line port file display-reference icon-name out))
 	   ((regexp-exec menu-item-regexp line)
 	    (loop line))
 	   (else
-	    (display-text line port file display-reference)
+	    (display-text line port file display-reference out)
 	    (finish-item-loop))))))))
 
 ;; Central dispatch
 
-(define (dispatch-line line port file display-reference icon-name)
+(define (dispatch-line line port file display-reference icon-name out)
   (cond
    ((or (eof-object? line) (node-epilogue? line)) #f)
-   ((string=? "" line) (emit-p #t) #t)
+   ((string=? "" line) (emit-p out) #t)
    ((regexp-exec menu-regexp line) #t) ;; this should probably be expanded
    ((regexp-exec menu-item-regexp line)
-    (display-menu line port file display-reference icon-name))
+    (display-menu line port file display-reference icon-name out))
    (else
-    (display-text line port file display-reference) #t)))
+    (display-text line port file display-reference out) #t)))
 
-(define (display-body port file display-reference icon-name)
+(define (display-body port file display-reference icon-name out)
   (let loop ()
     (let ((line (read-line port)))
-      (if (dispatch-line line port file display-reference icon-name)
+      (if (dispatch-line line port file display-reference icon-name out)
 	  (loop)))))
 	    
-(define (display-node node-name find-file display-reference icon-name)
+(define (display-node node-name find-file display-reference icon-name out)
+  (write (list 'node-name node-name)) (newline)
   (receive (file node) (parse-node-name node-name)
+    (write (list 'file file 'node node #\newline)) (newline)
     (receive (port file-header node-header up-header prev-header next-header)
 	(find-node file node find-file)
     
-      (with-tag #t html ()
-	(with-tag #t head ()
+      (with-tag out html ()
+	(with-tag out head ()
 	  (display-title file node-header up-header
 			 prev-header next-header
-			 display-reference icon-name))
-	(with-tag #t body ()
-	  (with-tag #t pre ()
-	    (display-body port file display-reference icon-name))))
+			 display-reference icon-name
+			 out))
+	(with-tag out body ()
+	  (with-tag out pre ()
+	    (display-body port file display-reference icon-name out))))
       
       (close-input-port port))))