* adapt rman-gateway to new response philosophy
* add rman-gateway to example server * add init proc to http-test in start-web-server
This commit is contained in:
interp
parent
5bced0b8f7
commit
7ca34fa270
|
|
@ -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 "(.*)\\((.)\\)")))
|
||||
|
|
|
|||
|
|
@ -839,6 +839,7 @@
|
|||
handle-fatal-error
|
||||
scsh
|
||||
let-opt
|
||||
sunet-utilities
|
||||
srfi-13
|
||||
scheme)
|
||||
(files (httpd rman-gateway)))
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
@ -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>
|
||||
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>
|
||||
|
|
|
|||
Loading…
Reference in New Issue