scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

modify seval-handler: 

*don't use concept of reader-writer-body (which is broken), use
writer-body instead -> seval-handler now works correctly
*use new interface READ-MESSAGE-BODY from handler-lib for reading in the
message body
*rename READ-REQUEST-SEXP to PARSE-REQUEST-SEXP
*catch errors thrown by READ in PARSE-REQUEST-SEXP to answer 400
instead of 500 for requests whose message body doesn't contain a valid
s-expression
This commit is contained in:
vibr 2005-04-16 20:33:35 +00:00
parent 36db985453
commit 555d52806d
1 changed files with 42 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

110
scheme/httpd/seval.scm
View File

@ -9,10 +9,6 @@
;;; This is really just an handler example demonstrating how to upload code ;;; This is really just an handler example demonstrating how to upload code
;;; into the server. ;;; into the server.
;;; Besides, this handler has always been broken because it makes use
;;; of the concept of http-reader-writer-body which is broken
;;; itself. See response.scm.
;;; (do/timeout secs thunk) ;;; (do/timeout secs thunk)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Run THUNK, and gun it down if it hasn't finished in SECS seconds. ;;; Run THUNK, and gun it down if it hasn't finished in SECS seconds.
@ -51,75 +47,48 @@
(define (seval path req) (define (seval path req)
(let ((body-length (get-body-length-from-content-length req))) ;;make sure we have a valid Content-length header in request (let* ((message-body (read-message-body req))
(sexp (parse-request-sexp message-body)))
(make-response (make-response
(status-code ok) (status-code ok)
#f #f
(time) (time)
"text/html" "text/html"
'() '()
(make-reader-writer-body ;; see response.scm for an explanation why the concept of http-reader-writer-body doesn't work (make-writer-body
(lambda (iport oport options) (lambda (oport options)
(with-fatal-error-handler (http-syslog (syslog-level debug) "read sexp: ~a" sexp)
(emit-prolog oport)
(with-tag oport html (xmlnsdecl-attr)
(newline oport)
(with-tag oport head ()
(newline oport)
(emit-title oport "Scheme program output")
(newline oport))
(newline oport)
(lambda (c decline) (with-tag oport body ()
;; no matter what kind of error (might be a server internal error), we emit this webpage: (newline oport)
(emit-prolog oport) (do/timeout
(with-tag oport html (xmlnsdecl-attr) 10
(newline oport) (receive vals
(with-tag oport head () ;; Do the computation.
(newline oport) (begin (emit-header oport 1 "Output from execution")
(emit-title oport "No Program") (newline oport)
(newline oport)) (with-tag oport pre ()
(newline oport) (newline oport)
(with-tag oport body () (force-output oport); In case we're gunned down.
(newline oport) (with-current-output-port oport
(emit-header oport 1 "No Program") (eval-safely sexp))))
(newline oport)
(with-tag oport p ()
(display
"No program was found in the body of the request.
The request's body must be form-url encoded and contain a \"program=<sexp>\" pair."
oport)
(newline oport))
(newline oport))
(newline oport)))
(let ((sexp (read-request-sexp body-length iport))) ;; Pretty-print the returned value(s).;; hier noch mal newline rausschreiben?
(http-syslog (syslog-level debug) "read sexp: ~a" sexp) (emit-header oport 1 "Return value(s)")
(emit-prolog oport) (with-tag oport pre ()
(with-tag oport html (xmlnsdecl-attr) (for-each (lambda (val) (p val oport))
(newline oport) vals)))))))))))
(with-tag oport head ()
(newline oport)
(emit-title oport "Scheme program output")
(newline oport))
(newline oport)
(with-tag oport body ()
(newline oport)
(do/timeout
10
(receive vals
;; Do the computation.
(begin (emit-header oport 1 "Output from execution")
(newline oport)
(with-tag oport pre ()
(newline oport)
(force-output oport); In case we're gunned down.
(with-current-output-port oport
(eval-safely sexp))))
;; Pretty-print the returned value(s).;; hier noch mal newline rausschreiben?
(emit-header oport 1 "Return value(s)")
(with-tag oport pre ()
(for-each (lambda (val) (p val oport))
vals)))))))))))))
;;; Read an HTTP request entity body from stdin. The Content-length: ;;; Parse the request's message body.
;;; entity-header field of request REQ tells how many bytes this entity
;;; is.
;;; We assume, that the entity is "form-url encoded" data (see ;;; We assume, that the entity is "form-url encoded" data (see
;;; parse-forms.scm for a description of this encoding). This ;;; parse-forms.scm for a description of this encoding). This
@ -129,12 +98,13 @@ The request's body must be form-url encoded and contain a \"program=<sexp>\" pai
;;; Pull out the program=<stuff> string, extract <stuff>, ;;; Pull out the program=<stuff> string, extract <stuff>,
;;; parse that into an s-expression, and return it. ;;; parse that into an s-expression, and return it.
(define (read-request-sexp bytes iport) (define (parse-request-sexp body)
(let* (let* ((parsed-html-form-query (parse-html-form-query body))
((body (read-string bytes iport)) ;;read in bytes chars (program (cond ((assoc "program" parsed-html-form-query) => cdr)
(parsed-html-form-query (parse-html-form-query body)) ;; and parse them up. (else (fatal-syntax-error "No program was found in request's message body.")))))
(program (cond ((assoc "program" parsed-html-form-query) => cdr)
(else (error "No program in entity body.")))))
(http-syslog (syslog-level debug) (http-syslog (syslog-level debug)
"Seval sexp: ~s" program) "Seval sexp: ~s" program)
(read (make-string-input-port program)))) ;; return first sexp, discard others (with-fatal-error-handler
(lambda (c decline)
(fatal-syntax-error "The program in the request's message body isn't a valid s-expression"))
(read (make-string-input-port program))))) ;; return first sexp, discard others