* adapt rman-gateway to new response philosophy

* add rman-gateway to example server
* add init proc to http-test in start-web-server

scheme/httpd/rman-gateway.scm

@@ -10,11 +10,14 @@
 ;;; (RosettaMan is based at
 ;;;   ftp.cs.berkeley.edu:/ucb/people/phelps/tcltk/rman.tar.Z)
 
-(define rman/rman '("/afs/wsi/rs_aix41/bin/rman" -fHTML))
+;(define rman/rman '("/afs/wsi/rs_aix41/bin/rman" -fHTML))
 (define rman/man '(man))
 (define rman/nroff '(nroff -man))
-(define rman/gzcat '("/afs/wsi/rs_aix41/bin/zcat"))
+;(define rman/gzcat '("/afs/wsi/rs_aix41/bin/zcat"))
-(define rman/zcat '("/afs/wsi/rs_aix41/bin/zcat"))
+;(define rman/zcat '("/afs/wsi/rs_aix41/bin/zcat"))
+(define rman/rman '("/usr/bin/rman" -fHTML))
+(define rman/gzcat '("/usr/bin/zcat"))
+(define rman/zcat '("/usr/bin/zcat"))
 
 (define (rman-handler finder referencer address . maybe-man)
   (let ((parse-man-url
@@ -50,49 +53,53 @@
 		      (cddr (condition-stuff c))))
 	      (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")))
 	   
-	   (receive (man-path entry and-then) (parse-man-url (request:url req))
+	   (make-response
-		    (emit-man-page entry man man-path and-then reference-template))
+	    http-status/ok
-	   
+	    (status-code->text http-status/ok)
-	   (with-tag #t address ()
+	    (time)
-		     (display address))))
+	    "text/html"
+	    '()
+	    (make-writer-body
+	     (lambda (out options)
+	       (receive (man-path entry and-then) 
+		   (parse-man-url (request:url req))
+		 (emit-man-page entry man man-path and-then reference-template out))
+	       
+	       (with-tag out address ()
+		 (display address out)))))))
 	 (else (http-error http-status/method-not-allowed req)))))))
 
-(define (cat-man-page key section)
+(define (cat-man-page key section out)
   (let ((title (if section
 		   (format #f "~a(~a) manual page" key section)
 		   (format #f "~a manual page" key))))
-    (emit-title #t title)
+    (emit-title out title)
-    (emit-header #t 1 title)
+    (emit-header out 1 title)
-    (newline)
+    (newline out)
-    (with-tag #t body ()
+    (with-tag out body ()
-      (with-tag #t pre ()
+      (with-tag out pre ()
 	(copy-inport->outport (current-input-port)
-			      (current-output-port))))))
+			      out)))))
 
-(define (emit-man-page entry man man-path and-then reference-template)
+(define (emit-man-page entry man man-path and-then reference-template out)
   (receive (key section) (parse-man-entry entry)
     (let ((status
-	   (cond
+	   (with-current-output-port 
-	    ((procedure? and-then)
+	    out
-	     (run (| (begin (man section key man-path))
+	    (cond
-		     (begin (and-then key section)))
+	     ((procedure? and-then)
-		  stdports))
+	      (run (| (begin (man section key man-path))
-	    (else
+		      (begin (and-then key section)))
-	     (run (| (begin (man section key man-path))
+		   stdports))
-		     (,@rman/rman ,@and-then
+	     (else
-				  -r ,(reference-template entry section)))
+	      (run (| (begin (man section key man-path))
-		  stdports)))))
+		      (,@rman/rman ,@and-then
+				   -r ,(reference-template entry section)))
+		   stdports))))))
 
       (if (not (zero? status))
-	  (http-error http-status/internal-error #f
+	  (error "internal error emitting man page")))))
-		      "internal error emitting man page")))))
       
 (define parse-man-entry
   (let ((entry-regexp (make-regexp "(.*)\\((.)\\)")))

scheme/packages.scm

@@ -839,6 +839,7 @@
 	handle-fatal-error
 	scsh
 	let-opt
+	sunet-utilities
 	srfi-13
 	scheme)
   (files (httpd rman-gateway)))

start-web-server

@@ -11,6 +11,7 @@ exec scsh -lm packages.scm -dm -o http-test -e main -s "$0" "$@"
 	httpd-file-directory-handlers
 	cgi-server
 	seval-handler
+	rman-gateway
 	let-opt
         scsh             
         scheme)          
@@ -32,11 +33,18 @@ exec scsh -lm packages.scm -dm -o http-test -e main -s "$0" "$@"
 "
 	      ))
 
-    (define htdocs-dir "web-server/root/htdocs")
+    (define htdocs-dir #f)
-    (define cgi-bin-dir "web-server/root/cgi-bin")
+    (define cgi-bin-dir #f)
-    (define port "8080")
+    (define port #f)
-    (define log-file-name "web-server/httpd.log")
+    (define log-file-name #f)
-    (define root "web-server/root")
+    (define root #f)
+
+    (define (init)
+      (set! htdocs-dir "web-server/root/htdocs")
+      (set! cgi-bin-dir "web-server/root/cgi-bin")
+      (set! port "8080")
+      (set! log-file-name "web-server/httpd.log")
+      (set! root "web-server/root"))
 
     (define get-options
       (let* ((unknown-option-error
@@ -94,6 +102,7 @@ exec scsh -lm packages.scm -dm -o http-test -e main -s "$0" "$@"
 
     
     (define (main args)
+      (init)
       (get-options (cdr args))
       (format #t "options read~%")
       (cond ((zero? (user-uid))
@@ -123,7 +132,13 @@ exec scsh -lm packages.scm -dm -o http-test -e main -s "$0" "$@"
 	      (alist-path-dispatcher
 	       (list (cons "h" (home-dir-handler "public_html"))
 		     (cons "seval" seval-handler) 
+		     (cons "man" (rman-handler #f "man?%s(%s)" 
+					       "bernauer@informatik.uni-tuebingen.de"))
 		     (cons "cgi-bin" (cgi-handler cgi-bin-dir)))
 	       (rooted-file-or-directory-handler htdocs-dir)))))))))
 ))
 ;; EOF
+
+;;; Local Variables:
+;;; mode:scheme
+;;; End:

web-server/root/htdocs/index2.html

@@ -8,7 +8,11 @@
     Following files are available:
     <ul>
       <li><a href=../cgi-bin/comments.sh>A small CGI script</a></li>
-      <li><a href=seval.html>Computing Scheme Froms Interactively</a></li>
+      <li><a href=seval.html>Computing Scheme Forms
+	  Interactively</a></li>
+      <li><a href=man?man>Get a man page</a><br>
+	  (provided a matching man page installation;<br>
+	&nbsp;see httpd/rman-gateway.scm for details)</li>
       <li><a href=files/text.txt>Text file</a></li>
       <li><a href=files>Directory</a></li>
       <li><a href=files/zipped.gz>Compressed File</a></li>
@@ -21,7 +25,7 @@
     <hr>
     <!-- Created: Thu Aug 22 16:44:16 CEST 2002 -->
     <!-- hhmts start -->
-Last modified: Wed Aug 28 17:56:06 CEST 2002
+Last modified: Thu Aug 29 12:51:43 CEST 2002
 <!-- hhmts end -->
   </body>
 </html>