diff --git a/scheme/httpd/seval.scm b/scheme/httpd/seval.scm index 496a884..4c1108f 100644 --- a/scheme/httpd/seval.scm +++ b/scheme/httpd/seval.scm @@ -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= 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= ;;; string, extract , 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)) +