factor out parsing of content-length header value -> GET-CONTENT-LENGTH
generalize parsing of content-length header value to parse all header field values of the form 1*DIGIT -> GET-NUMERIC-FIELD-VALUE check for valid content-length header in SEVAL before answering 200 TODO: SEVAL is still buggy for request with invalid _body_
This commit is contained in:
vibr
parent
9fcfcf36f0
commit
ffbe3b21cd
|
|
@ -47,69 +47,104 @@
|
|||
|
||||
|
||||
(define (seval path req)
|
||||
;;bug: we make 200 response, no matter if the request contained a valid Content-length: header or not (see below)
|
||||
(let ((body-length (get-content-length req))) ;;make sure we have a valid Content-length header in request
|
||||
(make-response
|
||||
(status-code ok)
|
||||
#f
|
||||
(time)
|
||||
"text/html"
|
||||
'()
|
||||
(make-reader-writer-body
|
||||
;; this procedure's body is not evaluated until display-http-body is called from sent-http-response.
|
||||
;; this way the errors which are thrown by read-request-sexp for unvalid Content-length headers are syslogged
|
||||
;; (and no body is written out at all), but we still have the 200 status-line.
|
||||
(lambda (iport oport options)
|
||||
(let ((sexp (read-request-sexp req iport)))
|
||||
(make-reader-writer-body
|
||||
(lambda (iport oport options)
|
||||
;;still buggy: if the body of the request is not a valid html-form-query
|
||||
;;or does not contain program=<stuff> we answer 200 but
|
||||
;;don't send a body (as read-request-sexp throws an exception)
|
||||
(let ((sexp (read-request-sexp body-length iport)))
|
||||
(http-syslog (syslog-level debug) "read sexp: ~a" sexp)
|
||||
(with-tag oport head ()
|
||||
(newline oport)
|
||||
(emit-title oport "Scheme program output"))
|
||||
(newline oport)
|
||||
|
||||
(with-tag oport body ()
|
||||
(newline oport)
|
||||
(do/timeout
|
||||
10
|
||||
(receive vals
|
||||
;; Do the computation.
|
||||
(begin (emit-header oport 2 "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).
|
||||
(emit-header oport 2 "Return value(s)")
|
||||
(with-tag oport pre ()
|
||||
(for-each (lambda (val) (p val oport))
|
||||
vals))))))))))
|
||||
(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 2 "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 2 "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:
|
||||
;;; element of request REQ's header tells how many bytes to this entity
|
||||
;;; entity-header field of request REQ tells how many bytes this entity
|
||||
;;; is. The entity should be a URI-encoded form body. Pull out the
|
||||
;;; program=<stuff>
|
||||
;;; string, extract <stuff>, uri-decode it, parse that into an s-expression,
|
||||
;;; and return it.
|
||||
|
||||
(define (read-request-sexp req iport)
|
||||
(cond
|
||||
((get-header (request-headers req) 'content-length) =>
|
||||
(lambda (cl-str) ; Take the first Content-length: header,
|
||||
(let* ((cl-start (string-skip cl-str char-set:whitespace)) ; skip whitespace,
|
||||
(cl (if cl-start ; & convert to
|
||||
(string->number (substring cl-str ; a number.
|
||||
cl-start
|
||||
(string-length cl-str)))
|
||||
0)) ; All whitespace?? -- WTF.
|
||||
(qs (read-string cl iport)) ; Read in CL chars,
|
||||
(q (parse-html-form-query qs)) ; and parse them up.
|
||||
(s (cond ((assoc "program" q) => cdr)
|
||||
(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.")))))
|
||||
(http-syslog (syslog-level debug)
|
||||
"Seval sexp: ~s" s)
|
||||
(read (make-string-input-port s)))))
|
||||
(else (error "No `Content-length:' field in POST request."))))
|
||||
(http-syslog (syslog-level debug)
|
||||
"Seval sexp: ~s" program)
|
||||
(read (make-string-input-port program)))) ;; return first sexp, discard others
|
||||
|
||||
|
||||
;; GET-NUMERIC-FIELD-VALUE
|
||||
;; generalized function to get a field value of the form 1*DIGIT
|
||||
|
||||
;; check wether a header-field with name field-name is contained in req;
|
||||
;; if so, check wether ist field-content conforms to
|
||||
;; field-content = *LWS 1*DIGIT *LWS
|
||||
;; (i.e. optional leading whitespaces, at least one digit, optional trailing whitespace);
|
||||
;; if so, return digit as a number
|
||||
|
||||
;; req is a request record, field-name a symbol
|
||||
(define (get-numeric-field-value req field-name)
|
||||
(let*
|
||||
;;take first Content-length: header (RFC 2616 allows only one Content-length: header)
|
||||
((field-content (get-header (request-headers req) field-name))
|
||||
(field-value-start (string-skip field-content char-set:whitespace));; skip whitespace, ;;char-set:whitespace = LWS from RFC2616?
|
||||
(field-value (if field-value-start ;;yes, field content contained non-whitespace chars
|
||||
(string->number (substring field-content
|
||||
field-value-start
|
||||
(string-length field-content))) ;;trailing whitespace? RFC allows it! ->
|
||||
;; probably read-rfc822-headers in rfc822.scm should do the job of skipping leading and trailing whitespace?*
|
||||
(http-error (status-code bad-request) req
|
||||
(format #f "~A header contained only whitespace" field-name)))))
|
||||
(if (and (integer? field-value) (>= field-value 0)) ;;yes, field value contained only digits
|
||||
field-value
|
||||
(http-error (status-code bad-request) req
|
||||
(format #f "~A header contained characters other than digits" field-name)))))
|
||||
|
||||
|
||||
;;* RFC 2616, 4.2: The field-content does not include any leading or
|
||||
;;trailing LWS: linear white space occurring before the first
|
||||
;;non-whitespace character of the field-value or after the last
|
||||
;;non-whitespace character of the field-value. Such leading or
|
||||
;;trailing LWS MAY be removed without changing the semantics of the
|
||||
;;field value.
|
||||
|
||||
(define (get-content-length req)
|
||||
(get-numeric-field-value req 'content-length))
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue