adapt seval-handler to new response philosophy
FIXME: problems with input port in POST request
This commit is contained in:
parent
7fd23a0ceb
commit
a2aed3280e
|
@ -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))))
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue