From 7ca34fa270e426281e178130617a64ff65623a41 Mon Sep 17 00:00:00 2001 From: interp Date: Thu, 29 Aug 2002 10:51:47 +0000 Subject: [PATCH] * 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 | 75 ++++++++++++++++-------------- scheme/packages.scm | 1 + start-web-server | 25 ++++++++-- web-server/root/htdocs/index2.html | 8 +++- 4 files changed, 68 insertions(+), 41 deletions(-) diff --git a/scheme/httpd/rman-gateway.scm b/scheme/httpd/rman-gateway.scm index b44b3a5..b265f20 100644 --- a/scheme/httpd/rman-gateway.scm +++ b/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/zcat '("/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/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)) - (emit-man-page entry man man-path and-then reference-template)) - - (with-tag #t address () - (display address)))) + (make-response + http-status/ok + (status-code->text http-status/ok) + (time) + "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-header #t 1 title) - (newline) - (with-tag #t body () - (with-tag #t pre () + (emit-title out title) + (emit-header out 1 title) + (newline out) + (with-tag out body () + (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 - ((procedure? and-then) - (run (| (begin (man section key man-path)) - (begin (and-then key section))) - stdports)) - (else - (run (| (begin (man section key man-path)) - (,@rman/rman ,@and-then - -r ,(reference-template entry section))) - stdports))))) + (with-current-output-port + out + (cond + ((procedure? and-then) + (run (| (begin (man section key man-path)) + (begin (and-then key section))) + stdports)) + (else + (run (| (begin (man section key man-path)) + (,@rman/rman ,@and-then + -r ,(reference-template entry section))) + stdports)))))) (if (not (zero? status)) - (http-error http-status/internal-error #f - "internal error emitting man page"))))) + (error "internal error emitting man page"))))) (define parse-man-entry (let ((entry-regexp (make-regexp "(.*)\\((.)\\)"))) diff --git a/scheme/packages.scm b/scheme/packages.scm index d010874..9e7d9ac 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -839,6 +839,7 @@ handle-fatal-error scsh let-opt + sunet-utilities srfi-13 scheme) (files (httpd rman-gateway))) diff --git a/start-web-server b/start-web-server index f742ed1..34f5504 100755 --- a/start-web-server +++ b/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 cgi-bin-dir "web-server/root/cgi-bin") - (define port "8080") - (define log-file-name "web-server/httpd.log") - (define root "web-server/root") + (define htdocs-dir #f) + (define cgi-bin-dir #f) + (define port #f) + (define log-file-name #f) + (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: \ No newline at end of file diff --git a/web-server/root/htdocs/index2.html b/web-server/root/htdocs/index2.html index 911a606..4dbdb20 100644 --- a/web-server/root/htdocs/index2.html +++ b/web-server/root/htdocs/index2.html @@ -8,7 +8,11 @@ Following files are available: