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_

scheme/httpd/seval.scm

@@ -47,7 +47,7 @@
 
 
 (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
@@ -55,15 +55,19 @@
      "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)))
+	;;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)
+	  (emit-prolog oport)
+	  (with-tag oport html (xmlnsdecl-attr)
+		    (newline oport)
 		    (with-tag oport head ()
 			      (newline oport)
-	    (emit-title oport "Scheme program output"))
+			      (emit-title oport "Scheme program output")
+			      (newline oport))
 		    (newline oport)
 		    
 		    (with-tag oport body ()
@@ -80,36 +84,67 @@
 							 (with-current-output-port oport
 										   (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)")
 					(with-tag oport pre ()
 						  (for-each (lambda (val) (p val oport))
-			   vals))))))))))
+							    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)
+(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.")))))
     (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))
+