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

(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
	   (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))
	  (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")))