2000-09-26 11:32:01 -04:00
|
|
|
|
;;; man page -> HTML gateway for the SU web server. -*- Scheme -*-
|
2002-08-27 05:03:22 -04:00
|
|
|
|
|
|
|
|
|
;;; This file is part of the Scheme Untergrund Networking package.
|
|
|
|
|
|
2003-01-07 09:38:02 -05:00
|
|
|
|
;;; Copyright (c) 1996-2003 by Mike Sperber.
|
2002-08-27 05:03:22 -04:00
|
|
|
|
;;; For copyright information, see the file COPYING which comes with
|
|
|
|
|
;;; the distribution.
|
|
|
|
|
|
2003-01-07 09:38:02 -05:00
|
|
|
|
;;; This uses RosettaMan
|
|
|
|
|
;;; (based at ftp.cs.berkeley.edu:/ucb/people/phelps/tcltk/rman.tar.Z)
|
2000-09-26 11:32:01 -04:00
|
|
|
|
|
2003-01-07 09:38:02 -05:00
|
|
|
|
(define (rman-handler man-binary
|
|
|
|
|
nroff-binary
|
|
|
|
|
rman-binary
|
|
|
|
|
gzcat-binary
|
|
|
|
|
finder referencer address . maybe-man)
|
2000-09-26 11:32:01 -04:00
|
|
|
|
(let ((parse-man-url
|
|
|
|
|
(cond
|
|
|
|
|
((procedure? finder) finder)
|
|
|
|
|
((list? finder)
|
|
|
|
|
(lambda (url)
|
|
|
|
|
(values finder
|
2002-11-29 09:56:58 -05:00
|
|
|
|
(unescape-uri (http-url-search url))
|
2000-09-26 11:32:01 -04:00
|
|
|
|
'())))
|
|
|
|
|
(else
|
2004-05-12 15:28:04 -04:00
|
|
|
|
(let ((man-path
|
|
|
|
|
((infix-splitter ":")
|
|
|
|
|
(or (getenv "MANPATH")
|
|
|
|
|
(begin
|
|
|
|
|
(format (current-error-port)
|
|
|
|
|
"~%Warning: environment variable MANPATH is unset.~%")
|
|
|
|
|
"")))))
|
2000-09-26 11:32:01 -04:00
|
|
|
|
(lambda (url)
|
|
|
|
|
(values man-path
|
2002-11-29 09:56:58 -05:00
|
|
|
|
(unescape-uri (http-url-search url))
|
2000-09-26 11:32:01 -04:00
|
|
|
|
'()))))))
|
|
|
|
|
(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)
|
2002-11-29 09:49:22 -05:00
|
|
|
|
(let ((request-method (request-method req)))
|
2001-08-20 07:31:03 -04:00
|
|
|
|
(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))))
|
|
|
|
|
|
2002-08-29 06:51:47 -04:00
|
|
|
|
(make-response
|
2003-01-09 10:05:30 -05:00
|
|
|
|
(status-code ok)
|
|
|
|
|
#f
|
2002-08-29 06:51:47 -04:00
|
|
|
|
(time)
|
|
|
|
|
"text/html"
|
|
|
|
|
'()
|
|
|
|
|
(make-writer-body
|
|
|
|
|
(lambda (out options)
|
2004-08-14 18:08:07 -04:00
|
|
|
|
(emit-prolog out)
|
2002-08-29 06:51:47 -04:00
|
|
|
|
(receive (man-path entry and-then)
|
2002-11-29 09:49:22 -05:00
|
|
|
|
(parse-man-url (request-url req))
|
2003-01-07 09:38:02 -05:00
|
|
|
|
(emit-man-page man-binary nroff-binary rman-binary
|
|
|
|
|
gzcat-binary
|
|
|
|
|
entry man man-path and-then reference-template out))
|
2002-08-29 06:51:47 -04:00
|
|
|
|
|
2004-08-14 18:08:07 -04:00
|
|
|
|
(with-tag out address () ;;au<61>erhalb des html elements?
|
2002-08-29 06:51:47 -04:00
|
|
|
|
(display address out)))))))
|
2004-08-11 10:51:51 -04:00
|
|
|
|
((or (string=? request-method "HEAD")
|
|
|
|
|
(string=? request-method "POST"))
|
2003-01-10 04:52:35 -05:00
|
|
|
|
(make-error-response (status-code method-not-allowed) req
|
2004-08-11 10:51:51 -04:00
|
|
|
|
"GET"))
|
|
|
|
|
(else
|
|
|
|
|
(make-error-response (status-code not-implemented) req)))))))
|
|
|
|
|
|
2000-09-26 11:32:01 -04:00
|
|
|
|
|
2002-08-29 06:51:47 -04:00
|
|
|
|
(define (cat-man-page key section out)
|
2000-09-26 11:32:01 -04:00
|
|
|
|
(let ((title (if section
|
|
|
|
|
(format #f "~a(~a) manual page" key section)
|
|
|
|
|
(format #f "~a manual page" key))))
|
2002-08-29 06:51:47 -04:00
|
|
|
|
(emit-title out title)
|
|
|
|
|
(emit-header out 1 title)
|
|
|
|
|
(newline out)
|
|
|
|
|
(with-tag out body ()
|
|
|
|
|
(with-tag out pre ()
|
2000-09-26 11:32:01 -04:00
|
|
|
|
(copy-inport->outport (current-input-port)
|
2002-08-29 06:51:47 -04:00
|
|
|
|
out)))))
|
2000-09-26 11:32:01 -04:00
|
|
|
|
|
2003-01-07 09:38:02 -05:00
|
|
|
|
(define (emit-man-page man-binary nroff-binary rman-binary
|
|
|
|
|
gzcat-binary
|
|
|
|
|
entry man man-path and-then reference-template out)
|
2000-09-26 11:32:01 -04:00
|
|
|
|
(receive (key section) (parse-man-entry entry)
|
|
|
|
|
(let ((status
|
2002-08-30 08:04:27 -04:00
|
|
|
|
(cond
|
|
|
|
|
((procedure? and-then)
|
2003-01-07 09:38:02 -05:00
|
|
|
|
(run (| (begin (man man-binary nroff-binary gzcat-binary
|
|
|
|
|
section key man-path))
|
2004-02-02 05:22:21 -05:00
|
|
|
|
(begin (and-then key section out)))
|
2003-01-07 09:38:02 -05:00
|
|
|
|
(= 1 ,out)
|
|
|
|
|
(= 2 ,out)))
|
|
|
|
|
(else
|
|
|
|
|
(run (| (begin (man man-binary nroff-binary gzcat-binary
|
|
|
|
|
section key man-path))
|
|
|
|
|
(,rman-binary "-fHTML"
|
|
|
|
|
,@and-then
|
|
|
|
|
"-r" ,(reference-template entry section)))
|
|
|
|
|
(= 1 ,out)
|
|
|
|
|
(= 2 ,out))))))
|
2000-09-26 11:32:01 -04:00
|
|
|
|
|
|
|
|
|
(if (not (zero? status))
|
2002-08-29 06:51:47 -04:00
|
|
|
|
(error "internal error emitting man page")))))
|
2000-09-26 11:32:01 -04:00
|
|
|
|
|
|
|
|
|
(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))))))
|
|
|
|
|
|
2003-01-07 09:38:02 -05:00
|
|
|
|
(define (man man-binary nroff-binary gzcat-binary section key man-path)
|
2000-09-26 11:32:01 -04:00
|
|
|
|
(cond
|
|
|
|
|
((procedure? man-path) (man-path))
|
2003-01-07 09:38:02 -05:00
|
|
|
|
((find-man-file key section "cat" man-path) =>
|
|
|
|
|
(lambda (file)
|
|
|
|
|
(cat-n-decode gzcat-binary file)))
|
|
|
|
|
((find-man-file key section "man" man-path) =>
|
|
|
|
|
(lambda (file)
|
2003-01-28 16:15:50 -05:00
|
|
|
|
(nroff-n-decode nroff-binary gzcat-binary file)))
|
2000-09-26 11:32:01 -04:00
|
|
|
|
(else
|
|
|
|
|
(if (not (zero?
|
2001-10-08 13:33:13 -04:00
|
|
|
|
(with-env (("MANPATH" . ,(string-join man-path ":")))
|
2003-01-07 09:38:02 -05:00
|
|
|
|
(run (,man-binary "-man" ,@(if section `(,section) '()) ,key)
|
2002-02-21 09:00:42 -05:00
|
|
|
|
stdports))))
|
2003-01-09 10:05:30 -05:00
|
|
|
|
(http-error (status-code not-found) #f "man page not found")))))
|
2000-09-26 11:32:01 -04:00
|
|
|
|
|
|
|
|
|
(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)))))))
|
|
|
|
|
|
2003-01-07 09:38:02 -05:00
|
|
|
|
(define (cat-n-decode gzcat-binary file)
|
2000-09-26 11:32:01 -04:00
|
|
|
|
(let ((ext (file-name-extension file)))
|
|
|
|
|
(cond
|
2003-01-07 09:38:02 -05:00
|
|
|
|
((string=? ".gz" ext) (run (,gzcat-binary ,file) stdports))
|
|
|
|
|
((string=? ".Z" ext) (run (,gzcat-binary ,file) stdports))
|
2000-09-26 11:32:01 -04:00
|
|
|
|
(else (call-with-input-file
|
|
|
|
|
file
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(copy-inport->outport port (current-output-port))))))))
|
|
|
|
|
|
2003-01-07 09:38:02 -05:00
|
|
|
|
(define (nroff-n-decode nroff-binary gzcat-binary file)
|
|
|
|
|
(if (not (zero? (run (| (begin (cat-n-decode gzcat-binary file))
|
2000-09-26 11:32:01 -04:00
|
|
|
|
(begin
|
|
|
|
|
(with-cwd (file->man-directory file)
|
2003-01-07 09:38:02 -05:00
|
|
|
|
(exec-epf (,nroff-binary "-man")))))
|
2002-02-21 09:00:42 -05:00
|
|
|
|
stdports)))
|
2003-01-09 10:05:30 -05:00
|
|
|
|
(http-error (status-code not-found) #f "man page not found")))
|