sunet/scheme/httpd/rman-gateway.scm

;;; 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-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))))

	   (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))))
	 (else (http-error http-status/method-not-allowed req)))))))

(define (cat-man-page key section)
  (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 ()
	(copy-inport->outport (current-input-port)
			      (current-output-port))))))

(define (emit-man-page entry man man-path and-then reference-template)
  (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)))))

      (if (not (zero? status))
	  (http-error http-status/internal-error #f
		      "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")))