adapt seval-handler to new response philosophy

FIXME: problems with input port in POST request
This commit is contained in:
interp 2002-08-28 15:41:52 +00:00
parent 7fd23a0ceb
commit a2aed3280e
2 changed files with 73 additions and 34 deletions

View File

@ -38,6 +38,15 @@
(syntax-rules ()
((do/timeout secs body ...) (do/timeout* secs (lambda () body ...)))))
(define-condition-type 'seval-error '())
(define seval-error? (condition-predicate 'seval-error))
(define-condition-type 'seval-no-content-length-error '(seval-error))
(define seval-no-content-length-error?
(condition-predicate 'seval-no-content-length-error))
(define-condition-type 'seval-no-program '(seval-error))
(define seval-no-program? (condition-predicate 'seval-no-program))
;;; The path handler for seval ops.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -46,37 +55,65 @@
(let ((request-method (request:method req)))
(cond
((string=? request-method "POST") ; Could do others also.
(call-with-current-continuation
(lambda (exit)
(begin
(with-handler
(lambda (condition more)
(exit
(cond
((seval-no-content-length-error? condition)
(make-http-error-response
http-status/bad-request req
"No `Content-length:' field in POST request."))
((seval-no-program? condition)
(make-http-error-response http-status/bad-request req
"No program in entity body."))
(else
(make-http-error-response
http-status/internal-error req
"Unknown error while evaluating seval-expression."
condition)))))
(lambda ()
(seval path req)))))))
(else
(make-http-error-response http-status/method-not-allowed req)))))
(let ((modern-protocol? (not (v0.9-request? req))))
(if modern-protocol?
(begin
(begin-http-header #t 200)
(write-string "Content-type: text/html\r\n\r\n")))
(with-tag #t HEAD ()
(newline)
(emit-title #t "Scheme program output"))
(newline))
(with-tag #t BODY ()
(newline)
(let ((sexp (read-request-sexp req)))
(do/timeout
10
(receive vals
;; Do the computation.
(begin (emit-header #t 2 "Output from execution")
(newline)
(with-tag #t PRE ()
(newline)
(force-output) ; In case we're gunned down.
(eval-safely sexp)))
;; Pretty-print the returned value(s).
(emit-header #t 2 "Return value(s)")
(with-tag #t PRE ()
(for-each p vals)))))))
(else (http-error http-status/method-not-allowed #f req)))))
(define (seval path req)
(let ((sexp (read-request-sexp req)))
(http-syslog (syslog-level debug) "read sexp: ~a" sexp)
(make-response
http-status/ok
(status-code->text http-status/ok)
(time)
"text/html"
'()
(make-writer-body
(lambda (port options)
(with-tag port HEAD ()
(newline port)
(emit-title port "Scheme program output"))
(newline port)
(with-tag port BODY ()
(newline port)
(do/timeout
10
(receive vals
;; Do the computation.
(begin (emit-header port 2 "Output from execution")
(newline port)
(with-tag port PRE ()
(newline port)
(force-output port); In case we're gunned down.
(eval-safely sexp)))
;; Pretty-print the returned value(s).
(emit-header port 2 "Return value(s)")
(with-tag port PRE ()
(for-each (lambda (val) (p val port))
vals))))))))))
;;; Read an HTTP request entity body from stdin. The Content-length:
@ -97,11 +134,11 @@
(string-length cl-str)))
0)) ; All whitespace?? -- WTF.
(qs (read-string cl)) ; Read in CL chars,
;; FIXME where is the input port?
(q (parse-html-form-query qs)) ; and parse them up.
(s (cond ((assoc "program" q) => cdr)
(else (error "No program in entity body.")))))
(else (signal 'seval-no-program)))))
(http-syslog (syslog-level debug)
"Seval sexp:~%~s~%" s)
"Seval sexp: ~s" s)
(read (make-string-input-port s)))))
(else (http-error http-status/bad-request req
"No Content-length: field in POST request."))))
(else (signal 'seval-no-content-length-error))))

View File

@ -448,6 +448,7 @@
(open receiving ; MV return (RECEIVE and VALUES)
scsh-utilities ; index
srfi-13
srfi-1 ; fold
let-opt ; let-optionals
crlf-io ; read-crlf-line
ascii ; ascii->char
@ -804,6 +805,7 @@
srfi-13 ; STRING-SKIP
rfc822
toothless-eval ; EVAL-SAFELY
conditions signals
handle ; IGNORE-ERROR
parse-html-forms ; PARSE-HTML-FORM-QUERY
threads ; SLEEP