simplified get-numeric-field-value (now uses string-trim-both),
adapted packages.scm
This commit is contained in:
parent
8bf71fc3a5
commit
ffac0ebcac
|
@ -80,29 +80,24 @@
|
||||||
|
|
||||||
;; 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 not, return #f,
|
;; if not, return #f,
|
||||||
;; if there is one, check wether its field-content conforms to
|
;; else, take the first such header field and 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);
|
|
||||||
;; if so, return digit as a number
|
;; if so, return digit as a number
|
||||||
|
|
||||||
(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)
|
;;try to get first "field-name" header
|
||||||
((field-content (get-header (request-headers req) field-name)))
|
((field-content (get-header (request-headers req) field-name)))
|
||||||
(if field-content
|
(if field-content ;; request contained "field-name" header
|
||||||
(let*
|
(let ;;see * below
|
||||||
((field-value-start (string-skip field-content char-set:whitespace));; skip whitespace, ;;char-set:whitespace = LWS from RFC2616?
|
((field-value (string->number (string-trim-both field-content char-set:whitespace)))) ;;char-set:whitespace = LWS from RFC2616?
|
||||||
(field-value (if field-value-start ;;yes, field content contained non-whitespace chars
|
(if (and (integer? field-value) (>= field-value 0)) ;;yes, field value contained only digits, and at least one digit.
|
||||||
(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
|
field-value
|
||||||
(http-error (status-code bad-request) req
|
(http-error
|
||||||
(format #f "~A header contained characters other than digits or whitespace between digits" field-name))))
|
(status-code bad-request) req
|
||||||
|
(format #f
|
||||||
|
"~A header contained only whitespace, or characters other than digits, or whitespace between digits"
|
||||||
|
field-name))))
|
||||||
#f)))
|
#f)))
|
||||||
|
|
||||||
|
|
||||||
|
@ -112,12 +107,14 @@
|
||||||
;;non-whitespace character of the field-value. Such leading or
|
;;non-whitespace character of the field-value. Such leading or
|
||||||
;;trailing LWS MAY be removed without changing the semantics of the
|
;;trailing LWS MAY be removed without changing the semantics of the
|
||||||
;;field value.
|
;;field value.
|
||||||
|
;;(probably read-rfc822-headers in rfc822.scm should do the job of skipping leading and trailing whitespace?)
|
||||||
|
|
||||||
;;get request's message-body length from Content-length: header or
|
;;get request's message-body length from Content-length: header or
|
||||||
;;throw http-error if no such header
|
;;throw http-error if no such header
|
||||||
(define (get-body-length-from-content-length req)
|
(define (get-body-length-from-content-length req)
|
||||||
(let ((maybe-length (get-numeric-field-value req 'content-length)))
|
(let
|
||||||
|
;;try to get field value of first Content-length header (RFC 2616 allows only one Content-length: header)
|
||||||
|
((maybe-length (get-numeric-field-value req 'content-length)))
|
||||||
(or maybe-length
|
(or maybe-length
|
||||||
(http-error (status-code bad-request) req "No Content-Length header in request"))))
|
(http-error (status-code bad-request) req "No Content-Length header in request"))))
|
||||||
|
|
||||||
|
|
|
@ -604,7 +604,7 @@
|
||||||
(open scheme-with-scsh
|
(open scheme-with-scsh
|
||||||
format-net
|
format-net
|
||||||
sigevents
|
sigevents
|
||||||
(subset srfi-13 (string-join string-skip))
|
(subset srfi-13 (string-join string-skip string-trim-both))
|
||||||
dns
|
dns
|
||||||
let-opt ; :optional
|
let-opt ; :optional
|
||||||
locks
|
locks
|
||||||
|
|
Loading…
Reference in New Issue