* new response body: :HTTP-READER-WRITER-BODY

* hand over SOCKET:INPORT to SEND-HTTP-RESPONSE
* apply this to seval-handler
This commit is contained in:
interp 2002-08-28 16:44:07 +00:00
parent 57c6710012
commit 62b3307fb2
4 changed files with 51 additions and 40 deletions

View File

@ -157,16 +157,16 @@
(decline)))) (decline))))
(lambda () (lambda ()
(let* ((req (parse-http-request sock options)) (let* ((req (parse-http-request sock options))
(response (response ((httpd-options-path-handler options)
(with-current-input-port
(socket:inport sock)
((httpd-options-path-handler options)
(http-url:path (request:url req)) (http-url:path (request:url req))
req)))) req)))
(values req response))))) (values req response)))))
(lambda (req response) (lambda (req response)
(send-http-response req response (socket:outport sock) options) (send-http-response req response
(socket:inport sock)
(socket:outport sock)
options)
(http-log req http-status/ok)))))) (http-log req http-status/ok))))))
@ -292,13 +292,13 @@
(write-crlf port)) (write-crlf port))
(define (send-http-response request response port options) (define (send-http-response request response input-port output-port options)
(if (not (v0.9-request? request)) (if (not (v0.9-request? request))
(send-http-headers response port)) (send-http-headers response output-port))
(if (not (string=? (request:method request) "HEAD")) (if (not (string=? (request:method request) "HEAD"))
(display-http-body (response-body response) port options))) (display-http-body (response-body response) input-port output-port options)))
(define (send-http-header-fields headers port) (define (send-http-header-fields headers port)
(for-each (lambda (pair) (for-each (lambda (pair)

View File

@ -20,8 +20,18 @@
writer-body? writer-body?
(proc writer-body-proc)) (proc writer-body-proc))
(define (display-http-body body port options) (define-record-type :http-reader-writer-body
((writer-body-proc body) port options)) (make-reader-writer-body proc)
reader-writer-body?
(proc reader-writer-body-proc))
(define (display-http-body body iport oport options)
(cond
((writer-body? body)
((writer-body-proc body) oport options))
((reader-writer-body? body)
((reader-writer-body-proc body) iport oport options))))
(define-syntax define-http-status-codes (define-syntax define-http-status-codes

View File

@ -81,39 +81,39 @@
(make-http-error-response http-status/method-not-allowed req))))) (make-http-error-response http-status/method-not-allowed req)))))
(define (seval path req) (define (seval path req)
(let ((sexp (read-request-sexp req)))
(http-syslog (syslog-level debug) "read sexp: ~a" sexp)
(make-response (make-response
http-status/ok http-status/ok
(status-code->text http-status/ok) (status-code->text http-status/ok)
(time) (time)
"text/html" "text/html"
'() '()
(make-writer-body (make-reader-writer-body
(lambda (port options) (lambda (iport oport options)
(with-tag port HEAD () (let ((sexp (read-request-sexp req iport)))
(newline port) (http-syslog (syslog-level debug) "read sexp: ~a" sexp)
(emit-title port "Scheme program output")) (with-tag oport HEAD ()
(newline port) (newline oport)
(emit-title oport "Scheme program output"))
(with-tag port BODY () (newline oport)
(newline port)
(do/timeout (with-tag oport BODY ()
10 (newline oport)
(receive vals (do/timeout
;; Do the computation. 10
(begin (emit-header port 2 "Output from execution") (receive vals
(newline port) ;; Do the computation.
(with-tag port PRE () (begin (emit-header oport 2 "Output from execution")
(newline port) (newline oport)
(force-output port); In case we're gunned down. (with-tag oport PRE ()
(eval-safely sexp))) (newline oport)
(force-output oport); In case we're gunned down.
;; Pretty-print the returned value(s). (eval-safely sexp)))
(emit-header port 2 "Return value(s)")
(with-tag port PRE () ;; Pretty-print the returned value(s).
(for-each (lambda (val) (p val port)) (emit-header oport 2 "Return value(s)")
vals)))))))))) (with-tag oport PRE ()
(for-each (lambda (val) (p val oport))
vals))))))))))
;;; Read an HTTP request entity body from stdin. The Content-length: ;;; Read an HTTP request entity body from stdin. The Content-length:
@ -123,7 +123,7 @@
;;; string, extract <stuff>, uri-decode it, parse that into an s-expression, ;;; string, extract <stuff>, uri-decode it, parse that into an s-expression,
;;; and return it. ;;; and return it.
(define (read-request-sexp req) (define (read-request-sexp req iport)
(cond (cond
((get-header (request:headers req) 'content-length) => ((get-header (request:headers req) 'content-length) =>
(lambda (cl-str) ; Take the first Content-length: header, (lambda (cl-str) ; Take the first Content-length: header,
@ -133,7 +133,7 @@
cl-start cl-start
(string-length cl-str))) (string-length cl-str)))
0)) ; All whitespace?? -- WTF. 0)) ; All whitespace?? -- WTF.
(qs (read-string cl)) ; Read in CL chars, (qs (read-string cl iport)) ; Read in CL chars,
(q (parse-html-form-query qs)) ; and parse them up. (q (parse-html-form-query qs)) ; and parse them up.
(s (cond ((assoc "program" q) => cdr) (s (cond ((assoc "program" q) => cdr)
(else (signal 'seval-no-program))))) (else (signal 'seval-no-program)))))

View File

@ -332,6 +332,7 @@
response-body response-body
make-writer-body writer-body? make-writer-body writer-body?
make-reader-writer-body reader-writer-body?
display-http-body display-http-body
;; Integer reply codes ;; Integer reply codes