diff --git a/scheme/httpd/seval.scm b/scheme/httpd/seval.scm index 99b2297..6cf2298 100644 --- a/scheme/httpd/seval.scm +++ b/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")))) - - diff --git a/scheme/lib/sunet-utilities.scm b/scheme/lib/sunet-utilities.scm index e5fad20..db47d19 100644 --- a/scheme/lib/sunet-utilities.scm +++ b/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")))) + diff --git a/scheme/packages.scm b/scheme/packages.scm index b23208e..cf10e2d 100644 --- a/scheme/packages.scm +++ b/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)))