adapt to new response philosophy (not tested yet)

This commit is contained in:
interp 2002-08-29 14:05:55 +00:00
parent 7ca34fa270
commit 50fa27f993
1 changed files with 66 additions and 59 deletions

View File

@ -148,21 +148,25 @@
(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 (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))
(with-tag #t address ()
(write-string address))))
(make-response
http-status/ok
(status-code->text http-status/ok)
(time)
"text/html"
'()
(make-writer-body
(lambda (out options)
(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) out)
icon-name
out))
(with-tag out address ()
(write-string address out)))))))
(else (http-error http-status/method-not-allowed req)))))))
(define split-header-line
@ -219,23 +223,23 @@
(values file node))
(string-append "(" file ")" node))))
(define (display-icon file alt)
(emit-tag #t 'img
(define (display-icon file alt out)
(emit-tag out 'img
(cons 'src file)
(cons 'alt alt)
(cons 'align "bottom")))
(define (referencer make-reference old-entry)
(define (referencer make-reference old-entry out)
(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)))))
(with-tag out 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))))))
(display-icon (car maybe-icon) (cadr maybe-icon) out))
(emit-text label out))))))
(define node-prologue (ascii->char 31))
(define node-epilogue-regexp
@ -256,30 +260,30 @@
;; Document title
(define (display-title file node up previous next
display-reference icon-name)
display-reference icon-name out)
(define (maybe-display-header header icon alt)
(if header
(begin
(newline)
(with-tag #t b ()
(with-tag out b ()
(display-reference file header header icon alt)))))
(emit-title #t (string-append "Info Node: "
(emit-title out (string-append "Info Node: "
(unparse-node-name file node)))
(with-tag #t h1 ()
(emit-tag #t 'img
(with-tag out h1 ()
(emit-tag out 'img
(cons 'src (icon-name 'info))
(cons 'alt "Info Node")
(cons 'align 'bottom))
(write-string (unparse-node-name file node)))
(emit-tag #t 'hr)
(write-string (unparse-node-name file node) out))
(emit-tag out '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)))
(emit-tag out 'hr)))
;; Text
@ -311,7 +315,7 @@
(loop (string-append line cr new-line) (- count 1))))))))))
(define (display-xref xref file display-reference)
(define (display-xref xref file display-reference out)
(let* ((match (regexp-exec xref-regexp xref))
(note (match:substring match 1))
(node-name (match:substring match 2))
@ -319,22 +323,22 @@
(node-name (substring node-name
(string-skip node-name char-set:whitespace)
(string-length node-name))))
(emit-text "See ")
(emit-text "See " out)
(display-reference file node-name note)))
(define display-text
(let ((split-xrefs (infix-splitter xref-regexp #f 'split)))
(lambda (line port file display-reference)
(lambda (line port file display-reference out)
(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))
(emit-text (car components) out)
(if (not (null? (cdr components)))
(begin
(display-xref (cadr components) file display-reference)
(display-xref (cadr components) file display-reference out)
(loop (cddr components))))))
(newline)))))
@ -353,7 +357,7 @@
(define colon-split (char-splitter #\:))
(define (display-menu-item-header line port file display-reference icon-name)
(define (display-menu-item-header line port file display-reference icon-name out)
(let ((menu-line-split (infix-splitter menu-item-regexp)))
(receive (note rest) (colon-split (cadr (menu-line-split line)))
(receive (node-name text)
@ -367,24 +371,24 @@
(match:substring match 2))))
(else
(info-gateway-error "invalid menu item")))
(emit-tag #t 'dt)
(emit-tag out '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)))))))
(emit-tag out 'dd)
(display-text text port file display-reference out)))))))
(define (display-menu line port file display-reference icon-name)
(emit-close-tag #t 'pre)
(define (display-menu line port file display-reference icon-name out)
(emit-close-tag out 'pre)
(with-tag #t dl ()
(with-tag out 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)
(display-menu-item-header line port file display-reference icon-name out)
(let finish-item-loop ()
(if (eof-object? line)
@ -395,45 +399,48 @@
((or (eof-object? line)
(node-epilogue? line)
(string=? "" line))
(emit-tag #t 'pre)
(dispatch-line line port file display-reference icon-name))
(emit-tag out 'pre)
(dispatch-line line port file display-reference icon-name out))
((regexp-exec menu-item-regexp line)
(loop line))
(else
(display-text line port file display-reference)
(display-text line port file display-reference out)
(finish-item-loop))))))))
;; Central dispatch
(define (dispatch-line line port file display-reference icon-name)
(define (dispatch-line line port file display-reference icon-name out)
(cond
((or (eof-object? line) (node-epilogue? line)) #f)
((string=? "" line) (emit-p #t) #t)
((string=? "" line) (emit-p out) #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))
(display-menu line port file display-reference icon-name out))
(else
(display-text line port file display-reference) #t)))
(display-text line port file display-reference out) #t)))
(define (display-body port file display-reference icon-name)
(define (display-body port file display-reference icon-name out)
(let loop ()
(let ((line (read-line port)))
(if (dispatch-line line port file display-reference icon-name)
(if (dispatch-line line port file display-reference icon-name out)
(loop)))))
(define (display-node node-name find-file display-reference icon-name)
(define (display-node node-name find-file display-reference icon-name out)
(write (list 'node-name node-name)) (newline)
(receive (file node) (parse-node-name node-name)
(write (list 'file file 'node node #\newline)) (newline)
(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 ()
(with-tag out html ()
(with-tag out 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))))
display-reference icon-name
out))
(with-tag out body ()
(with-tag out pre ()
(display-body port file display-reference icon-name out))))
(close-input-port port))))