rename get-content-length to get-body-length-from-content-length

move get-body-length-from-content-length and get-numeric-field-value
from seval.scm to sunet-utilities.scm

adapt packages.scm

scheme/httpd/seval.scm

@@ -47,7 +47,7 @@
 
 
 (define (seval path req)
-  (let ((body-length (get-content-length req))) ;;make sure we have a valid Content-length header in request
+  (let ((body-length (get-body-length-from-content-length req))) ;;make sure we have a valid Content-length header in request
     (make-response
      (status-code ok)
      #f
@@ -107,52 +107,3 @@
     (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 not, return #f,
-;; if there is one, check wether its 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)))
-    (if field-content
-	(let*
-	    ((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))))
-	#f)))
-
-
-
-
-;;* 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)
-  (let ((maybe-length (get-numeric-field-value req 'content-length)))
-    (or maybe-length
-	(http-error (status-code bad-request) req "No Content-Length header in request"))))
-
-

scheme/lib/sunet-utilities.scm

@@ -68,8 +68,56 @@
    (lambda ()
      (release-lock lock))))
 
-
 ;; Get Header from (RFC822 like) header alist
 (define (get-header headers tag)
   (cond ((assq tag headers) => cdr)
 	(else #f)))
+
+
+;; GET-NUMERIC-FIELD-VALUE
+;; generalized function to get a field value of the form 1*DIGIT
+;; req is a request record, field-name a symbol
+
+;; check wether a header-field with name field-name is contained in req;
+;; if not, return #f,
+;; if there is one, check wether its 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
+
+(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)))
+    (if field-content
+	(let*
+	    ((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))))
+	#f)))
+
+
+;;* 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.
+
+
+;;get request's message-body length from Content-length: header or
+;;throw http-error if no such header
+(define (get-body-length-from-content-length req)
+  (let ((maybe-length (get-numeric-field-value req 'content-length)))
+    (or maybe-length
+	(http-error (status-code bad-request) req "No Content-Length header in request"))))
+

scheme/packages.scm

@@ -263,7 +263,8 @@
 	  copy-inport->outport
 	  dotdot-check
 	  with-lock
-	  get-header))
+	  get-header
+	  get-body-length-from-content-length))
 
 (define-interface handle-fatal-error-interface
   (export with-fatal-error-handler*
@@ -602,11 +603,14 @@
   (open scheme-with-scsh
 	format-net
 	sigevents
-	(subset srfi-13 (string-join))
+	(subset srfi-13 (string-join string-skip))
 	dns
 	let-opt				; :optional
 	locks
-	handle-fatal-error)
+	handle-fatal-error
+	httpd-errors
+	httpd-requests
+	httpd-responses)
   (files (lib sunet-utilities)))
 
 (define-structure handle-fatal-error handle-fatal-error-interface
@@ -741,6 +745,7 @@
 	httpd-requests			; REQUEST record type, v0.9-request
 	(subset srfi-1 (fold-right))
 	(subset srfi-13 (string-trim string-prefix-ci?))
+	sunet-utilities
 	httpd-responses
 	httpd-errors
 	)
@@ -782,7 +787,7 @@
 	handle				; IGNORE-ERROR
 	parse-html-forms		; PARSE-HTML-FORM-QUERY
 	threads				; SLEEP
-	sunet-utilities			; GET-HEADER
+	sunet-utilities			
 	)
   (files (httpd seval)))