186 lines
5.5 KiB
Scheme
186 lines
5.5 KiB
Scheme
;;; man page -> HTML gateway for the SU web server. -*- Scheme -*-
|
|
|
|
;;; This file is part of the Scheme Untergrund Networking package.
|
|
|
|
;;; Copyright (c) 1996 by Mike Sperber.
|
|
;;; For copyright information, see the file COPYING which comes with
|
|
;;; the distribution.
|
|
|
|
;;; This uses RosettaMan and is currently based on version 2.5a6
|
|
;;; (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/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/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
|
|
(cond
|
|
((procedure? finder) finder)
|
|
((list? finder)
|
|
(lambda (url)
|
|
(values finder
|
|
(unescape-uri (http-url-search url))
|
|
'())))
|
|
(else
|
|
(let ((man-path ((infix-splitter ":") (getenv "MANPATH"))))
|
|
(lambda (url)
|
|
(values man-path
|
|
(unescape-uri (http-url-search url))
|
|
'()))))))
|
|
(reference-template
|
|
(cond
|
|
((procedure? referencer) referencer)
|
|
((string? referencer) (lambda (entry section) referencer))
|
|
(else (lambda (entry section) "man?%s(%s)"))))
|
|
(man (:optional maybe-man man)))
|
|
|
|
(lambda (path req)
|
|
(let ((request-method (request-method req)))
|
|
(cond
|
|
((string=? request-method "GET")
|
|
(with-fatal-error-handler
|
|
(lambda (c decline)
|
|
(cond
|
|
((http-error? c)
|
|
(apply http-error (car (condition-stuff c)) req
|
|
(cddr (condition-stuff c))))
|
|
(else
|
|
(decline))))
|
|
|
|
(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
|
|
(make-http-error-response http-status/method-not-allowed req
|
|
request-method)))))))
|
|
|
|
(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 out title)
|
|
(emit-header out 1 title)
|
|
(newline out)
|
|
(with-tag out body ()
|
|
(with-tag out pre ()
|
|
(copy-inport->outport (current-input-port)
|
|
out)))))
|
|
|
|
(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)))
|
|
(= 1 ,out)
|
|
(= 2 ,out)))
|
|
(else
|
|
(run (| (begin (man section key man-path))
|
|
(,@rman/rman ,@and-then
|
|
-r ,(reference-template entry section)))
|
|
(= 1 ,out)
|
|
(= 2 ,out))))))
|
|
|
|
(if (not (zero? status))
|
|
(error "internal error emitting man page")))))
|
|
|
|
(define parse-man-entry
|
|
(let ((entry-regexp (make-regexp "(.*)\\((.)\\)")))
|
|
(lambda (s)
|
|
(cond
|
|
((regexp-exec entry-regexp s)
|
|
=> (lambda (match)
|
|
(values (match:substring match 1)
|
|
(match:substring match 2))))
|
|
(else (values s #f))))))
|
|
|
|
(define (man section key man-path)
|
|
(cond
|
|
((procedure? man-path) (man-path))
|
|
((find-man-file key section "cat" man-path) => cat-n-decode)
|
|
((find-man-file key section "man" man-path) => nroff-n-decode)
|
|
(else
|
|
(if (not (zero?
|
|
(with-env (("MANPATH" . ,(string-join man-path ":")))
|
|
(run (,@rman/man ,@(if section `(,section) '()) ,key)
|
|
stdports))))
|
|
(http-error http-status/not-found #f "man page not found")))))
|
|
|
|
(define man-default-sections
|
|
'("1" "2" "3" "4" "5" "6" "7" "8" "9" "o" "l" "n" "p"))
|
|
|
|
(define (find-man-file name section cat-man man-path . maybe-sections)
|
|
|
|
(define (section-dir section)
|
|
(lambda (dir)
|
|
(file-name-as-directory
|
|
(string-append (file-name-as-directory dir)
|
|
cat-man
|
|
section))))
|
|
|
|
(let* ((prefix (if section
|
|
(string-append name "." section)
|
|
(string-append name ".")))
|
|
(pattern (string-append (glob-quote prefix) "*"))
|
|
(sections (:optional maybe-sections man-default-sections))
|
|
(path (if section
|
|
(map (section-dir section) man-path)
|
|
(apply append
|
|
(map (lambda (dir)
|
|
(map (lambda (section)
|
|
((section-dir section) dir))
|
|
sections))
|
|
man-path)))))
|
|
|
|
(let loop ((path path))
|
|
(and (not (null? path))
|
|
(let ((matches (glob (string-append (car path) pattern))))
|
|
(if (not (null? matches))
|
|
(car matches)
|
|
(loop (cdr path))))))))
|
|
|
|
(define (file->man-directory file)
|
|
(path-list->file-name
|
|
(reverse
|
|
(cdr
|
|
(reverse
|
|
(split-file-name
|
|
(file-name-directory file)))))))
|
|
|
|
(define (cat-n-decode file)
|
|
(let ((ext (file-name-extension file)))
|
|
(cond
|
|
((string=? ".gz" ext) (run (,@rman/gzcat ,file) stdports))
|
|
((string=? ".Z" ext) (run (,@rman/zcat ,file) stdports))
|
|
(else (call-with-input-file
|
|
file
|
|
(lambda (port)
|
|
(copy-inport->outport port (current-output-port))))))))
|
|
|
|
(define (nroff-n-decode file)
|
|
(if (not (zero? (run (| (begin (cat-n-decode file))
|
|
(begin
|
|
(with-cwd (file->man-directory file)
|
|
(exec-epf (,@rman/nroff)))))
|
|
stdports)))
|
|
(http-error http-status/not-found #f "man page not found")))
|