GET-NUMERIC-FIELD-VALUE now uses GET-HEADER from utilities.scm

and returns #f if GET-HEADER does so

adapted GET-CONTENT-LENGHT
This commit is contained in:
vibr 2004-08-14 21:18:12 +00:00
parent aea0e950ba
commit f8559581d2
1 changed files with 24 additions and 16 deletions

View File

@ -113,28 +113,34 @@
;; generalized function to get a field value of the form 1*DIGIT ;; 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; ;; check wether a header-field with name field-name is contained in req;
;; if so, check wether ist field-content conforms to ;; if not, return #f,
;; if there is one, check wether its field-content conforms to
;; field-content = *LWS 1*DIGIT *LWS ;; field-content = *LWS 1*DIGIT *LWS
;; (i.e. optional leading whitespaces, at least one digit, optional trailing whitespace); ;; (i.e. optional leading whitespaces, at least one digit, optional trailing whitespace);
;; if so, return digit as a number ;; if so, return digit as a number
;; req is a request record, field-name a symbol ;; req is a request record, field-name a symbol
(define (get-numeric-field-value req field-name) (define (get-numeric-field-value req field-name)
(let* (let
;;take first Content-length: header (RFC 2616 allows only one Content-length: header) ;;take first Content-length: header (RFC 2616 allows only one Content-length: header)
((field-content (get-header (request-headers req) field-name)) ((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? (if field-content
(field-value (if field-value-start ;;yes, field content contained non-whitespace chars (let*
(string->number (substring field-content ((field-value-start (string-skip field-content char-set:whitespace));; skip whitespace, ;;char-set:whitespace = LWS from RFC2616?
field-value-start (field-value (if field-value-start ;;yes, field content contained non-whitespace chars
(string-length field-content))) ;;trailing whitespace? RFC allows it! -> (string->number (substring field-content
;; probably read-rfc822-headers in rfc822.scm should do the job of skipping leading and trailing whitespace?* field-value-start
(http-error (status-code bad-request) req (string-length field-content))) ;;trailing whitespace? RFC allows it! ->
(format #f "~A header contained only whitespace" field-name))))) ;; probably read-rfc822-headers in rfc822.scm should do the job of skipping leading and trailing whitespace?*
(if (and (integer? field-value) (>= field-value 0)) ;;yes, field value contained only digits (http-error (status-code bad-request) req
field-value (format #f "~A header contained only whitespace" field-name)))))
(http-error (status-code bad-request) req (if (and (integer? field-value) (>= field-value 0)) ;;yes, field value contained only digits
(format #f "~A header contained characters other than digits" field-name))))) 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 ;;* RFC 2616, 4.2: The field-content does not include any leading or
@ -145,6 +151,8 @@
;;field value. ;;field value.
(define (get-content-length req) (define (get-content-length req)
(get-numeric-field-value req 'content-length)) (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"))))