sunet/info-gateway.scm

644 lines
20 KiB
Scheme
Raw Normal View History

2000-09-26 10:35:26 -04:00
;;; GNU info -> HTML gateway for the SU web server. -*- Scheme -*-
;;; Copyright (c) 1996 by Mike Sperber.
;;; based on code with the same purpose by Gaebe Engelhart
;;; (info-handler parse-info reference find-icon address) -> handler
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This function creates a path handler that converts GNU info pages
;;; on-the-fly. It is highly parameterizable to accomodate a wide
;;; range of environments. The parameters specify how to find the
;;; source code for the info pages, and how to generate certain
;;; elements of the generated HTML output.
;;;
;;; PARSE-INFO specifies how to parse the URLs that end up in the
;;; handler.
;;; It can be:
;;;
;;; * a procedure which is called with the URL as its parameters.
;;; It is expected to return with two values, FIND-ENTRY and
;;; NODE-NAME. FIND-ENTRY, in turn, can be either a procedure
;;; which gets passed the file name of an info node and is
;;; supposed to return with an absolute name of same. If it is a
;;; list, that list is taken as a list of directories in which to
;;; search for the info files. NODE-NAME is supposed to be the
;;; name of an info node of the form (<file>)<node>, extracted
;;; from the URL.
;;;
;;; * a list, in which case that is taken as a list of
;;; directories in which to search for the info files. The node
;;; name of a node is extracted from the URL by just taking the
;;; search component of the URL.
;;;
;;; * #f in which case the info path is taken from the environment
;;; variable INFOPATH, and the node name extraction works as
;;; above.
;;;
;;; REFERENCE specifies how to generate cross-references to other info
;;; nodes. It can be:
;;;
;;; * a procedure which gets called with the URL of the info page
;;; which contains the reference, and the node name of the node
;;; to be referenced. The procedure is expected to return the
;;; text for a link.
;;;
;;; * a string, in which case that is to be a prefix to which the
;;; node name is simply appended to yield the new link.
;;;
;;; * #f in which case all references have the form
;;; info?<node-name>.
;;;
;;; FIND-ICON specifies to to find the various icons used to decorate
;;; info pages. It can be:
;;;
;;; * a procedure which gets passed one of the tags in
;;; DEFAULT-ICON-ALIST and is supposed to return a link for the
;;; appropriate icon (or #f if no icon is to be used)
;;;
;;; * a string which is taken as a prefix to which one of the
;;; appropriate icon name from DEFAULT-ICON-ALIST is appended.
;;; (Note that these icon names were stolen from the
;;; cern-httpd-3.0 distribution at
;;; http://www.w3.org/pub/WWW/Daemon/.)
;;;
;;; * a list which is taken as an alist of the same format as
;;; DEFAULT-ICON-ALIST.
;;;
;;; * #f in which case no icons are used.
;;;
;;; ADDRESS a string to be appended at the bottom of all info pages
;;;
;;; To install a vanilla info handler for a prefix "info?" that looks
;;; in the environment variable INFOPATH, just use something like
;;; (info-handler #f #f #f "Generated by info-gateway")
;;; TODO: write a CGI version of this
(define-condition-type 'info-gateway-error '(error))
(define info-gateway-error? (condition-predicate 'info-gateway-error))
(define (info-gateway-error msg . irritants)
(apply signal 'info-gateway-error msg irritants))
(define default-icon-alist
'((info . "infodoc.gif")
(up . "up.gif")
(next . "next.gif")
(previous . "prev.gif")
(menu . "menu.gif")))
(define (info-handler parse-info reference find-icon address)
(let ((icon-name
(cond
((procedure? find-icon) find-icon)
((string? find-icon)
(let ((alist
(map (lambda (entry)
(cons (car entry)
(string-append find-icon (cdr entry))))
default-icon-alist)))
(lambda (tag)
(cond ((assq tag alist) => cdr)
(else #f)))))
((list? find-icon)
(lambda (tag)
(cond ((assq tag find-icon) => cdr)
(else #f))))
(else (lambda (tag) #f))))
(parse-info-url
(cond
((procedure? parse-info) parse-info)
((list? parse-info) ; it's an info path
(lambda (url)
(values parse-info
(unescape-uri (http-url:search url)))))
(else
(let ((info-path ((infix-splitter ":") (getenv "INFOPATH"))))
(lambda (url)
(values info-path
(unescape-uri (http-url:search url))))))))
(make-reference
(cond
((procedure? reference) reference)
((string? reference)
(lambda (url node-name)
(string-append reference node-name)))
(else
(lambda (url node-name)
(string-append "info?" node-name))))))
(lambda (path req)
(let ((request-method (request:method req)))
(cond
((string=? request-method "GET")
(with-fatal-error-handler
(lambda (c decline)
(cond
((info-gateway-error? c)
(apply http-error http-reply/internal-error req
(condition-stuff c)))
((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-reply/ok)
(write-string "Content-type: text/html\r\n")
(write-string "\r\n")))
(receive (find-entry node-name) (parse-info-url (request:url req))
(display-node node-name
(file-finder find-entry)
(referencer make-reference (request:url req))
icon-name))
2000-09-26 10:35:26 -04:00
(with-tag #t address ()
(write-string address))))
(else (http-error http-reply/method-not-allowed req)))))))
2000-09-26 10:35:26 -04:00
(define split-header-line
(let ((split (infix-splitter (make-regexp "(, *)|( +)|( *\t *)")))
(split-field (infix-splitter (make-regexp ": *"))))
2000-09-26 10:35:26 -04:00
(lambda (l)
(let ((fields (map split-field (split l))))
(define (search-field regexp)
(cond
((any (lambda (field)
(string-match regexp (car field)))
fields)
=> cadr)
(else #f)))
(values (search-field "[F|f]ile")
(search-field "[N|n]ode")
(search-field "[U|u]p")
(search-field "[P|p]rev(ious)?")
(search-field "[N|n]ext"))))))
(define (replace-if-empty-string s v)
(if (zero? (string-length s))
v
s))
(define (string-newline->space s)
(string-map (lambda (c)
(if (char=? c #\newline)
#\space
c))
s))
(define (parse-node-name node-name)
(cond
((string-match "^\\((.*)\\)(.*)$" (string-newline->space node-name))
=> (lambda (match)
(values
(replace-if-empty-string (match:substring match 1) #f)
(replace-if-empty-string (match:substring match 2) "Top"))))
(else (values #f (string-newline->space node-name)))))
(define (unparse-node-name file node)
(let* ((ext (file-name-extension file))
(file (if (string=? ext ".info")
(file-name-sans-extension file)
file)))
(receive (file node) (if (and (string=? "dir" file)
(not (string=? "" node))
(not (string=? "Top" node)))
(values node "Top")
(values file node))
(string-append "(" file ")" node))))
(define (display-icon file alt)
(emit-tag #t 'img
(cons 'src file)
(cons 'alt alt)
(cons 'align "bottom")))
(define (referencer make-reference old-entry)
(lambda (file node-name label . maybe-icon)
(receive (node-file node) (parse-node-name node-name)
(let ((file (or node-file file)))
(with-tag #t a ((href (make-reference
old-entry
(escape-uri (unparse-node-name file node)))))
(if (and (not (null? maybe-icon))
(car maybe-icon))
(display-icon (car maybe-icon) (cadr maybe-icon)))
(emit-text label))))))
(define node-prologue (ascii->char 31))
(define node-epilogue-regexp
(make-regexp
(string-append (regexp-quote (string node-prologue))
"|"
(regexp-quote (string (ascii->char 12))))))
(define (string-starts-with-char? s c)
(and (not (zero? (string-length s)))
(char=? c (string-ref s 0))))
(define (node-prologue? s)
(string-starts-with-char? s node-prologue))
(define (node-epilogue? s)
(regexp-exec node-epilogue-regexp s))
;; Document title
(define (display-title file node up previous next
display-reference icon-name)
(define (maybe-display-header header icon alt)
(if header
(begin
(newline)
(with-tag #t b ()
(display-reference file header header icon alt)))))
(emit-title #t (string-append "Info Node: "
(unparse-node-name file node)))
(with-tag #t h1 ()
(emit-tag #t 'img
(cons 'src (icon-name 'info))
(cons 'alt "Info Node")
(cons 'align 'bottom))
(write-string (unparse-node-name file node)))
(emit-tag #t 'hr)
(maybe-display-header next (icon-name 'next) "[Next]")
(maybe-display-header previous (icon-name 'previous) "[Previous]")
(maybe-display-header up (icon-name 'up) "[Up]")
(if (or next previous up)
(emit-tag #t 'hr)))
;; Text
;; Dealing with cross references
;; info sucks
(define xref-marker-regexp (make-regexp "\\*[Nn]ote([ \n]|$)"))
(define xref-regexp (make-regexp "\\*[Nn]ote *([^:]*): *([^\t\n,.;:?!]*)"))
(define max-xref-lines 3)
(define complete-line
(let ((split-xref-markers (field-splitter xref-marker-regexp))
(split-xrefs (field-splitter xref-regexp))
(cr (string #\newline)))
(lambda (line port)
(let loop ((line line) (count max-xref-lines))
(let ((xref-markers (split-xref-markers line))
(xrefs (split-xrefs line)))
(if (= (length xref-markers) (length xrefs))
line
(if (zero? count)
(info-gateway-error "invalid cross reference")
(let ((new-line (read-line port)))
(if (eof-object? new-line)
(info-gateway-error
"unexpected end of info file inside cross reference"))
(loop (string-append line cr new-line) (- count 1))))))))))
(define (display-xref xref file display-reference)
(let* ((match (regexp-exec xref-regexp xref))
(note (match:substring match 1))
(node-name (match:substring match 2))
(node-name (if (string=? "" node-name) note node-name))
(node-name (substring node-name
(string-skip node-name char-set:whitespace)
2000-09-26 10:35:26 -04:00
(string-length node-name))))
(emit-text "See ")
(display-reference file node-name note)))
(define display-text
(let ((split-xrefs (infix-splitter xref-regexp #f 'split)))
(lambda (line port file display-reference)
(let* ((line (complete-line line port))
(components (split-xrefs line)))
;; in components, every 2nd element is a cross reference
;; also, it always has odd length or length zero
(if (not (null? components))
(let loop ((components components))
(emit-text (car components))
(if (not (null? (cdr components)))
(begin
(display-xref (cadr components) file display-reference)
(loop (cddr components))))))
(newline)))))
;; Menus
(define menu-regexp (make-regexp "^\\* +Menu:"))
(define menu-item-regexp (make-regexp "^\\* +"))
(define (char-splitter c)
(lambda (s)
(cond ((string-index s c)
2000-09-26 10:35:26 -04:00
=> (lambda (i)
(values (substring s 0 i)
(substring s (+ 1 i) (string-length s)))))
(else (values s "")))))
(define colon-split (char-splitter #\:))
(define (display-menu-item-header line port file display-reference icon-name)
(let ((menu-line-split (infix-splitter menu-item-regexp)))
(receive (note rest) (colon-split (cadr (menu-line-split line)))
(receive (node-name text)
(cond
((string-match ": *(.*)" rest)
=> (lambda (match)
(values note (match:substring match 1))))
((string-match "^ *([^.]*)\\.? *(.*)" rest)
=> (lambda (match)
(values (match:substring match 1)
(match:substring match 2))))
(else
(info-gateway-error "invalid menu item")))
(emit-tag #t 'dt)
(display-reference file node-name note (icon-name 'menu) "*")
(newline)
(if (and (not (string=? "" text))
(not (string=? "." text)))
(begin
(emit-tag #t 'dd)
(display-text text port file display-reference)))))))
(define (display-menu line port file display-reference icon-name)
(emit-close-tag #t 'pre)
(with-tag #t dl ()
(let loop ((line line))
(if (eof-object? line)
(info-gateway-error "unexpected end of info file"))
(display-menu-item-header line port file display-reference icon-name)
(let finish-item-loop ()
(if (eof-object? line)
(info-gateway-error "unexpected end of info file"))
(let ((line (read-line port)))
(cond
((or (eof-object? line)
(node-epilogue? line)
(string=? "" line))
(emit-tag #t 'pre)
(dispatch-line line port file display-reference icon-name))
((regexp-exec menu-item-regexp line)
(loop line))
(else
(display-text line port file display-reference)
(finish-item-loop))))))))
;; Central dispatch
(define (dispatch-line line port file display-reference icon-name)
(cond
((or (eof-object? line) (node-epilogue? line)) #f)
((string=? "" line) (emit-p #t) #t)
((regexp-exec menu-regexp line) #t) ;; this should probably be expanded
((regexp-exec menu-item-regexp line)
(display-menu line port file display-reference icon-name))
(else
(display-text line port file display-reference) #t)))
(define (display-body port file display-reference icon-name)
(let loop ()
(let ((line (read-line port)))
(if (dispatch-line line port file display-reference icon-name)
(loop)))))
(define (display-node node-name find-file display-reference icon-name)
(receive (file node) (parse-node-name node-name)
(receive (port file-header node-header up-header prev-header next-header)
(find-node file node find-file)
(with-tag #t html ()
(with-tag #t head ()
(display-title file node-header up-header
prev-header next-header
display-reference icon-name))
(with-tag #t body ()
(with-tag #t pre ()
(display-body port file display-reference icon-name))))
(close-input-port port))))
;; Finding nodes
(define (ensure-node-prologue port msg)
(let ((line (read-line port)))
(if (or (eof-object? line)
(not (node-prologue line)))
(info-gateway-error "invalid info file" msg))))
(define (ensure-regexp-line port regexp msg)
(let ((line (read-line port)))
(if (or (eof-object? line)
(not (string-match regexp line)))
(info-gateway-error "invalid info file" msg))))
(define (ensure-tag-table-node port)
(ensure-regexp-line port "^Tag Table:" "no tag table"))
(define (ensure-indirect-tag-table-header port)
(ensure-regexp-line port "^\\(Indirect\\)" "no indirect tag"))
(define split-indirection (infix-splitter (make-regexp " *: *")))
2000-09-26 10:35:26 -04:00
(define (parse-indirection line)
(let ((l (split-indirection line)))
(if (null? (cdr l))
(info-gateway-error "invalid indirection entry in info file")
(let ((file (car l))
(seek-pos (string->number (cadr l))))
(if (not seek-pos)
(info-gateway-error "invalid indirection entry in info file"))
(cons file seek-pos)))))
(define (read-indirection-table port)
(let loop ((table '()))
(let ((line (read-line port)))
(if (eof-object? line)
(info-gateway-error "invalid info file"))
(if (node-epilogue? line)
(reverse table)
(loop (cons (parse-indirection line) table))))))
(define tag-seek-separator (ascii->char 127))
(define parse-tag
(let ((split (infix-splitter (make-regexp ", *")))
2000-09-26 10:35:26 -04:00
(split-field (infix-splitter ": "))
(split-node-info
(infix-splitter (string tag-seek-separator))))
2000-09-26 10:35:26 -04:00
(define (barf)
(info-gateway-error "invalid tag entry in info file"))
(lambda (line)
(let* ((fields (map split-field (split line)))
(file (cond
((assoc "File" fields)
=> (lambda (p)
(if (null? (cdr p)) (barf))
(cadr p)))
(else #f))))
(cond
((assoc "Node" fields)
=> (lambda (p)
(if (null? (cdr p)) (barf))
(let ((s (split-node-info (cadr p))))
(if (null? (cdr p)) (barf))
(let* ((node (car s))
(seek (string->number (cadr s))))
(if (not seek) (barf))
(values node file seek)))))
(else (barf)))))))
(define (find-tag node port)
(let loop ()
(let ((line (read-line port)))
(if (eof-object? line)
(info-gateway-error "invalid info file"))
(if (regexp-exec node-epilogue-regexp line)
(http-error http-reply/not-found #f "node not found"))
(receive (entry-node file seek) (parse-tag line)
(if (string=? node entry-node)
(cons file seek)
(loop))))))
(define (find-indirection-entry seek-pos indirection-table)
(let loop ((table indirection-table))
(if (null? table)
(http-error http-reply/not-found #f "node not found"))
(let* ((entry (car table))
(pos (cdr entry)))
(if (and (>= seek-pos pos)
(or (null? (cdr table))
(let* ((next-entry (cadr table))
(next-pos (cdr next-entry)))
(< seek-pos next-pos))))
entry
(loop (cdr table))))))
(define (file-finder with)
(cond ((procedure? with) with)
((list? with)
(lambda (file)
(find-info-file file with)))))
(define (find-node-port-with-tag-entry node tag-entry ? find-file)
(let* ((port (if (input-port? ?) ? #f))
(indirection-table (if port #f ?))
(seek-pos (cdr tag-entry))
(indirection-entry
(and indirection-table
(find-indirection-entry seek-pos indirection-table)))
(seek-pos (if indirection-entry
(- seek-pos (cdr indirection-entry))
seek-pos))
;; that's what the documentation says ...
(seek-pos (if (>= seek-pos 1000)
(- seek-pos 1000)
0))
(file (or (car tag-entry)
(and indirection-entry
(car indirection-entry))))
(port (if file
(begin
(if port (close-input-port port))
(open-input-file (find-file file)))
port)))
(seek port seek-pos)
port))
(define (find-node file node find-file)
(if (not file)
(http-error http-reply/not-found #f
"no file in info node specification"))
(let* ((fname (find-file file))
(port (open-input-file fname)))
(let loop ((port port))
(let ((line (read-line port)))
(if (eof-object? line)
(http-error http-reply/not-found #f "info node not found"))
(if (node-prologue? line)
(let ((header (read-line port)))
(if (eof-object? header)
(info-gateway-error "invalid info file"))
(cond
((string-match "^Indirect:" header)
(let ((indirection-table
(read-indirection-table port)))
(ensure-tag-table-node port)
(ensure-indirect-tag-table-header port)
(let ((tag-entry (find-tag node port)))
(close-input-port port)
(loop (find-node-port-with-tag-entry
node tag-entry indirection-table find-file)))))
((string-match "^Tag Table:" header)
(let ((tag-entry (find-tag node port)))
(loop (find-node-port-with-tag-entry
node tag-entry port find-file))))
((string-match "^File:" header)
(receive
(file-header node-header up-header prev-header next-header)
(split-header-line header)
(if (string=? node-header node)
(values port
file-header node-header
up-header prev-header next-header)
(loop port))))
(else (loop port))))
(loop port))))))
;; Finding files
(define (info-file-alternative-names file)
(receive (dir base ext) (parse-file-name file)
(let* ((base
(cond ((string-match "(.*)-info$" base)
=> (lambda (match)
(match:substring match 1)))
(else base)))
(base-ci (string-map char-downcase base))
2000-09-26 10:35:26 -04:00
(alts-1 (if (string=? base base-ci)
(list base)
(list base base-ci)))
(alts (append alts-1
(map (lambda (base)
(string-append base ".info"))
alts-1)))
(alts (append alts
(map (lambda (base)
(string-append base "-info"))
alts-1)))
(alts (map (lambda (f) (string-append dir f)) alts))
(alts (cons file alts)))
alts)))
(define (find-info-file file info-path)
(let ((alts (info-file-alternative-names file)))
(let path-loop ((path info-path))
(if (null? path)
(http-error http-reply/not-found #f "info file not found"))
(let alt-loop ((alts alts))
(if (null? alts)
(path-loop (cdr path))
(let ((try (string-append (file-name-as-directory (car path))
(car alts))))
(if (file-exists? try)
try
(alt-loop (cdr alts)))))))))