* 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:
parent
57c6710012
commit
62b3307fb2
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)))))
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue