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

114
scheme/httpd/seval.scm
View File

@ -9,10 +9,6 @@
;;; This is really just an handler example demonstrating how to upload code
;;; 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)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Run THUNK, and gun it down if it hasn't finished in SECS seconds.
@ -51,75 +47,48 @@
(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
(status-code ok)
#f
(time)
"text/html"
'()
(make-reader-writer-body ;; see response.scm for an explanation why the concept of http-reader-writer-body doesn't work
(lambda (iport oport options)
(with-fatal-error-handler
(lambda (c decline)
;; no matter what kind of error (might be a server internal error), we emit this webpage:
(emit-prolog oport)
(with-tag oport html (xmlnsdecl-attr)
(newline oport)
(with-tag oport head ()
(newline oport)
(emit-title oport "No Program")
(newline oport))
(newline oport)
(with-tag oport body ()
(newline oport)
(emit-header oport 1 "No Program")
(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)))
(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)
(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)))))))))))))
(make-writer-body
(lambda (oport options)
(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)
(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:
;;; entity-header field of request REQ tells how many bytes this entity
;;; is.
;;; Parse the request's message body.
;;; We assume, that the entity is "form-url encoded" data (see
;;; 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>,
;;; parse that into an s-expression, and return it.
(define (read-request-sexp bytes iport)
(let*
((body (read-string bytes iport)) ;;read in bytes chars
(parsed-html-form-query (parse-html-form-query body)) ;; and parse them up.
(program (cond ((assoc "program" parsed-html-form-query) => cdr)
(else (error "No program in entity body.")))))
(define (parse-request-sexp body)
(let* ((parsed-html-form-query (parse-html-form-query body))
(program (cond ((assoc "program" parsed-html-form-query) => cdr)
(else (fatal-syntax-error "No program was found in request's message body.")))))
(http-syslog (syslog-level debug)
"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