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

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 2004-08-14 19:07:23 +00:00
parent 9fcfcf36f0
commit ffbe3b21cd
1 changed files with 84 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

125
scheme/httpd/seval.scm
View File

@ -47,7 +47,7 @@
(define (seval path req) (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 (make-response
(status-code ok) (status-code ok)
#f #f
@ -55,61 +55,96 @@
"text/html" "text/html"
'() '()
(make-reader-writer-body (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) (lambda (iport oport options)
(let ((sexp (read-request-sexp req iport))) ;;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) (http-syslog (syslog-level debug) "read sexp: ~a" sexp)
(with-tag oport head () (emit-prolog oport)
(newline oport) (with-tag oport html (xmlnsdecl-attr)
(emit-title oport "Scheme program output")) (newline oport)
(newline oport) (with-tag oport head ()
(newline oport)
(emit-title oport "Scheme program output")
(newline oport))
(newline oport)
(with-tag oport body () (with-tag oport body ()
(newline oport) (newline oport)
(do/timeout (do/timeout
10 10
(receive vals (receive vals
;; Do the computation. ;; Do the computation.
(begin (emit-header oport 2 "Output from execution") (begin (emit-header oport 2 "Output from execution")
(newline oport) (newline oport)
(with-tag oport pre () (with-tag oport pre ()
(newline oport) (newline oport)
(force-output oport); In case we're gunned down. (force-output oport); In case we're gunned down.
(with-current-output-port oport (with-current-output-port oport
(eval-safely sexp)))) (eval-safely sexp))))
;; Pretty-print the returned value(s). ;; Pretty-print the returned value(s).;; hier noch mal newline rausschreiben?
(emit-header oport 2 "Return value(s)") (emit-header oport 2 "Return value(s)")
(with-tag oport pre () (with-tag oport pre ()
(for-each (lambda (val) (p val oport)) (for-each (lambda (val) (p val oport))
vals)))))))))) vals))))))))))))
;;; Read an HTTP request entity body from stdin. The Content-length: ;;; 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 ;;; is. The entity should be a URI-encoded form body. Pull out the
;;; program=<stuff> ;;; program=<stuff>
;;; string, extract <stuff>, uri-decode it, parse that into an s-expression, ;;; string, extract <stuff>, uri-decode it, parse that into an s-expression,
;;; and return it. ;;; and return it.
(define (read-request-sexp req iport) (define (read-request-sexp bytes iport)
(cond (let*
((get-header (request-headers req) 'content-length) => ((body (read-string bytes iport)) ;;read in bytes chars
(lambda (cl-str) ; Take the first Content-length: header, (parsed-html-form-query (parse-html-form-query body)) ;; and parse them up.
(let* ((cl-start (string-skip cl-str char-set:whitespace)) ; skip whitespace, (program (cond ((assoc "program" parsed-html-form-query) => cdr)
(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)
(else (error "No program in entity body."))))) (else (error "No program in entity body.")))))
(http-syslog (syslog-level debug) (http-syslog (syslog-level debug)
"Seval sexp: ~s" s) "Seval sexp: ~s" program)
(read (make-string-input-port s))))) (read (make-string-input-port program)))) ;; return first sexp, discard others
(else (error "No `Content-length:' field in POST request."))))
;; 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))