From 50fa27f993328ba035fdf8d58a93adefe29f63e9 Mon Sep 17 00:00:00 2001 From: interp Date: Thu, 29 Aug 2002 14:05:55 +0000 Subject: [PATCH] adapt to new response philosophy (not tested yet) --- scheme/httpd/info-gateway.scm | 125 ++++++++++++++++++---------------- 1 file changed, 66 insertions(+), 59 deletions(-) diff --git a/scheme/httpd/info-gateway.scm b/scheme/httpd/info-gateway.scm index 793b55e..33baefd 100644 --- a/scheme/httpd/info-gateway.scm +++ b/scheme/httpd/info-gateway.scm @@ -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))))