From e2d4bfea009569b20e4295e5c9abbe53314f6f12 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 17 Dec 2010 12:01:34 +0100 Subject: [PATCH] build-response validates headers * module/web/response.scm (build-response): Add some validation, like for build-request. --- module/web/response.scm | 33 ++++++++++++++++++++++++++++++++- 1 file changed, 32 insertions(+), 1 deletion(-) diff --git a/module/web/response.scm b/module/web/response.scm index 295b2f4bf..7acde1ec2 100644 --- a/module/web/response.scm +++ b/module/web/response.scm @@ -93,10 +93,41 @@ (define (bad-response message . args) (throw 'bad-response message args)) +(define (non-negative-integer? n) + (and (number? n) (>= n 0) (exact? n) (integer? n))) + +(define (validate-headers headers) + (if (pair? headers) + (let ((h (car headers))) + (if (pair? h) + (let ((k (car h)) (v (cdr h))) + (if (symbol? k) + (if (not (valid-header? k v)) + (bad-response "Bad value for header ~a: ~s" k v)) + (if (not (and (string? k) (string? v))) + (bad-response "Unknown header not a pair of strings: ~s" + h))) + (validate-headers (cdr headers))) + (bad-response "Header not a pair: ~a" h))) + (if (not (null? headers)) + (bad-response "Headers not a list: ~a" headers)))) + (define* (build-response #:key (version '(1 . 1)) (code 200) reason-phrase - (headers '()) port) + (headers '()) port (validate-headers? #t)) "Construct an HTTP response object. If @var{validate-headers?} is true, the headers are each run through their respective validators." + (cond + ((not (and (pair? version) + (non-negative-integer? (car version)) + (non-negative-integer? (cdr version)))) + (bad-response "Bad version: ~a" version)) + ((not (and (non-negative-integer? code) (< code 600))) + (bad-response "Bad code: ~a" code)) + ((and reason-phrase (not (string? reason-phrase))) + (bad-response "Bad reason phrase" reason-phrase)) + (else + (if validate-headers? + (validate-headers headers)))) (make-response version code reason-phrase headers port)) (define (extend-response r k v . additional)