scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

125
scheme/httpd/info-gateway.scm
View File

@ -148,21 +148,25 @@
(cddr (condition-stuff c)))) (cddr (condition-stuff c))))
(else (else
(decline)))) (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 () (make-response
(write-string address)))) 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))))))) (else (http-error http-status/method-not-allowed req)))))))
(define split-header-line (define split-header-line
@ -219,23 +223,23 @@
(values file node)) (values file node))
(string-append "(" file ")" node)))) (string-append "(" file ")" node))))
(define (display-icon file alt) (define (display-icon file alt out)
(emit-tag #t 'img (emit-tag out 'img
(cons 'src file) (cons 'src file)
(cons 'alt alt) (cons 'alt alt)
(cons 'align "bottom"))) (cons 'align "bottom")))
(define (referencer make-reference old-entry) (define (referencer make-reference old-entry out)
(lambda (file node-name label . maybe-icon) (lambda (file node-name label . maybe-icon)
(receive (node-file node) (parse-node-name node-name) (receive (node-file node) (parse-node-name node-name)
(let ((file (or node-file file))) (let ((file (or node-file file)))
(with-tag #t a ((href (make-reference (with-tag out a ((href (make-reference
old-entry old-entry
(escape-uri (unparse-node-name file node))))) (escape-uri (unparse-node-name file node)))))
(if (and (not (null? maybe-icon)) (if (and (not (null? maybe-icon))
(car maybe-icon)) (car maybe-icon))
(display-icon (car maybe-icon) (cadr maybe-icon))) (display-icon (car maybe-icon) (cadr maybe-icon) out))
(emit-text label)))))) (emit-text label out))))))
(define node-prologue (ascii->char 31)) (define node-prologue (ascii->char 31))
(define node-epilogue-regexp (define node-epilogue-regexp
@ -256,30 +260,30 @@
;; Document title ;; Document title
(define (display-title file node up previous next (define (display-title file node up previous next
display-reference icon-name) display-reference icon-name out)
(define (maybe-display-header header icon alt) (define (maybe-display-header header icon alt)
(if header (if header
(begin (begin
(newline) (newline)
(with-tag #t b () (with-tag out b ()
(display-reference file header header icon alt))))) (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))) (unparse-node-name file node)))
(with-tag #t h1 () (with-tag out h1 ()
(emit-tag #t 'img (emit-tag out 'img
(cons 'src (icon-name 'info)) (cons 'src (icon-name 'info))
(cons 'alt "Info Node") (cons 'alt "Info Node")
(cons 'align 'bottom)) (cons 'align 'bottom))
(write-string (unparse-node-name file node))) (write-string (unparse-node-name file node) out))
(emit-tag #t 'hr) (emit-tag out 'hr)
(maybe-display-header next (icon-name 'next) "[Next]") (maybe-display-header next (icon-name 'next) "[Next]")
(maybe-display-header previous (icon-name 'previous) "[Previous]") (maybe-display-header previous (icon-name 'previous) "[Previous]")
(maybe-display-header up (icon-name 'up) "[Up]") (maybe-display-header up (icon-name 'up) "[Up]")
(if (or next previous up) (if (or next previous up)
(emit-tag #t 'hr))) (emit-tag out 'hr)))
;; Text ;; Text
@ -311,7 +315,7 @@
(loop (string-append line cr new-line) (- count 1)))))))))) (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)) (let* ((match (regexp-exec xref-regexp xref))
(note (match:substring match 1)) (note (match:substring match 1))
(node-name (match:substring match 2)) (node-name (match:substring match 2))
@ -319,22 +323,22 @@
(node-name (substring node-name (node-name (substring node-name
(string-skip node-name char-set:whitespace) (string-skip node-name char-set:whitespace)
(string-length node-name)))) (string-length node-name))))
(emit-text "See ") (emit-text "See " out)
(display-reference file node-name note))) (display-reference file node-name note)))
(define display-text (define display-text
(let ((split-xrefs (infix-splitter xref-regexp #f 'split))) (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)) (let* ((line (complete-line line port))
(components (split-xrefs line))) (components (split-xrefs line)))
;; in components, every 2nd element is a cross reference ;; in components, every 2nd element is a cross reference
;; also, it always has odd length or length zero ;; also, it always has odd length or length zero
(if (not (null? components)) (if (not (null? components))
(let loop ((components components)) (let loop ((components components))
(emit-text (car components)) (emit-text (car components) out)
(if (not (null? (cdr components))) (if (not (null? (cdr components)))
(begin (begin
(display-xref (cadr components) file display-reference) (display-xref (cadr components) file display-reference out)
(loop (cddr components)))))) (loop (cddr components))))))
(newline))))) (newline)))))
@ -353,7 +357,7 @@
(define colon-split (char-splitter #\:)) (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))) (let ((menu-line-split (infix-splitter menu-item-regexp)))
(receive (note rest) (colon-split (cadr (menu-line-split line))) (receive (note rest) (colon-split (cadr (menu-line-split line)))
(receive (node-name text) (receive (node-name text)
@ -367,24 +371,24 @@
(match:substring match 2)))) (match:substring match 2))))
(else (else
(info-gateway-error "invalid menu item"))) (info-gateway-error "invalid menu item")))
(emit-tag #t 'dt) (emit-tag out 'dt)
(display-reference file node-name note (icon-name 'menu) "*") (display-reference file node-name note (icon-name 'menu) "*")
(newline) (newline)
(if (and (not (string=? "" text)) (if (and (not (string=? "" text))
(not (string=? "." text))) (not (string=? "." text)))
(begin (begin
(emit-tag #t 'dd) (emit-tag out 'dd)
(display-text text port file display-reference))))))) (display-text text port file display-reference out)))))))
(define (display-menu line port file display-reference icon-name) (define (display-menu line port file display-reference icon-name out)
(emit-close-tag #t 'pre) (emit-close-tag out 'pre)
(with-tag #t dl () (with-tag out dl ()
(let loop ((line line)) (let loop ((line line))
(if (eof-object? line) (if (eof-object? line)
(info-gateway-error "unexpected end of info file")) (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 () (let finish-item-loop ()
(if (eof-object? line) (if (eof-object? line)
@ -395,45 +399,48 @@
((or (eof-object? line) ((or (eof-object? line)
(node-epilogue? line) (node-epilogue? line)
(string=? "" line)) (string=? "" line))
(emit-tag #t 'pre) (emit-tag out 'pre)
(dispatch-line line port file display-reference icon-name)) (dispatch-line line port file display-reference icon-name out))
((regexp-exec menu-item-regexp line) ((regexp-exec menu-item-regexp line)
(loop line)) (loop line))
(else (else
(display-text line port file display-reference) (display-text line port file display-reference out)
(finish-item-loop)))))))) (finish-item-loop))))))))
;; Central dispatch ;; Central dispatch
(define (dispatch-line line port file display-reference icon-name) (define (dispatch-line line port file display-reference icon-name out)
(cond (cond
((or (eof-object? line) (node-epilogue? line)) #f) ((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-regexp line) #t) ;; this should probably be expanded
((regexp-exec menu-item-regexp line) ((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 (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 loop ()
(let ((line (read-line port))) (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))))) (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) (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) (receive (port file-header node-header up-header prev-header next-header)
(find-node file node find-file) (find-node file node find-file)
(with-tag #t html () (with-tag out html ()
(with-tag #t head () (with-tag out head ()
(display-title file node-header up-header (display-title file node-header up-header
prev-header next-header prev-header next-header
display-reference icon-name)) display-reference icon-name
(with-tag #t body () out))
(with-tag #t pre () (with-tag out body ()
(display-body port file display-reference icon-name)))) (with-tag out pre ()
(display-body port file display-reference icon-name out))))
(close-input-port port)))) (close-input-port port))))