From 40d7c923a2cfbf7cf3e227971154eb00fc863dc8 Mon Sep 17 00:00:00 2001 From: vibr Date: Wed, 13 Apr 2005 19:35:22 +0000 Subject: [PATCH] answer 505 (Version not supported) for requests with major version > implemented version: *new proc CHECK-MAJOR-HTTP-VERSION *new case in MAKE-ERROR-RESPONSE --- scheme/httpd/core.scm | 42 +++++++++++++++++++-------------------- scheme/httpd/response.scm | 16 +++++++++++++-- scheme/packages.scm | 7 ++----- 3 files changed, 37 insertions(+), 28 deletions(-) diff --git a/scheme/httpd/core.scm b/scheme/httpd/core.scm index 4f43762..9a553b5 100644 --- a/scheme/httpd/core.scm +++ b/scheme/httpd/core.scm @@ -2,10 +2,6 @@ ;;; This file is part of the Scheme Untergrund Networking package. -;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers. -;;; Copyright (c) 1996-2002 by Mike Sperber. -;;; Copyright (c) 2000-2002 by Martin Gasbichler. -;;; Copyright (c) 2002 by Andreas Bernauer. ;;; For copyright information, see the file COPYING which comes with ;;; the distribution. @@ -17,11 +13,17 @@ ;;; a complete server, you need to define request handlers (see below) -- ;;; they determine how requests are to be handled. ;;; -;;; The RFC detailing the HTTP 1.0 protocol, RFC 1945, can be found at -;;; http://www.w3.org/Protocols/rfc1945/rfc1945 +;;; See RFC 2616 for the specification of the HTTP/1.1 protocol. +;;; +;;; The server is compatible with previous versions of HTTP in the way +;;; described in RFC 2616 19.6. See RFC 1945 for the specification of +;;; HTTP/1.0 and 0.9. - -(define server/protocol "HTTP/1.0") +(define http-version-string + (string-append "HTTP/" + (number->string (car http-version)) + "." + (number->string (cdr http-version)))) (define (httpd options) (let ((port (httpd-options-port options)) @@ -168,7 +170,8 @@ (decline)))) (lambda () (let ((initial-req (parse-http-request sock options))) - (let redirect-loop ((req initial-req)) + (check-major-http-version initial-req) + (let redirect-loop ((req initial-req)) (let response-loop ((response ((httpd-options-request-handler options) (http-url-path (request-url req)) req))) @@ -216,18 +219,7 @@ '() ; no rfc822 headers (request-socket req)))) -;;;; HTTP request parsing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; This code provides procedures to read requests from an input -;;;; port. - ;;; Read and parse an http request from INPORT. -;;; -;;; Note: this parser parses the URI into an http URL record. If the URI -;;; isn't an http URL, the parser fails. This may not be right. There's -;;; nothing in the http protocol to prevent you from passing a non-http -;;; URI -- what this would mean, however, is not clear. Like so much of -;;; the Web, the protocols are redundant, underconstrained, and ill-specified. (define (parse-http-request sock options) (let ((line (read-crlf-line (socket:inport sock)))) @@ -270,6 +262,14 @@ (lose vstring)))))) +;;; check whether the request's major HTTP version is greater than the +;;; server's major HTTP version; if so, send 505 (Version not supported). + +(define (check-major-http-version req) + (if (> (car (request-version req)) (car http-version)) + (http-error (status-code version-not-supp) req))) + + ;;; Split string into a list of whitespace-separated strings. ;;; This could have been trivially defined in scsh as (field-splitter " \t\n") ;;; but I hand-coded it because it's short, and I didn't want invoke the @@ -289,7 +289,7 @@ (else '())))) (define (send-http-headers response port) - (display server/protocol port) + (display http-version-string port) (write-char #\space port) (display (status-code-number (response-code response)) port) (write-char #\space port) diff --git a/scheme/httpd/response.scm b/scheme/httpd/response.scm index b7f9509..5bf4177 100644 --- a/scheme/httpd/response.scm +++ b/scheme/httpd/response.scm @@ -1,10 +1,10 @@ ;;; This file is part of the Scheme Untergrund Networking package. -;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers. -;;; Copyright (c) 2002 by Mike Sperber. ;;; For copyright information, see the file COPYING which comes with ;;; the distribution. +(define http-version '(1 . 1));server's HTTP-version is only hardcoded here! + (define-record-type http-response :http-response (make-response code message seconds mime extras body) response? @@ -312,6 +312,18 @@ (lambda (port options) (generic-title port) (format port "This server received an invalid response from the upstream server it accessed in attempting to fulfill the request.~%") + (close-html port extras)))) + + ((eq? code (status-code version-not-supp)) + (create-writer-body-response + '() + (lambda (port options) + (generic-title port) + (format port "This server does not support the requested HTTP major version ~D.~%The highest HTTP major version supported is 1.~%" + (car (request-version req))) +; (format port "This server does not support the requested HTTP major version ~D.~%The highest HTTP major version supported is ~D.~%" +; (car (request-version req)) +; (car http-version)) (close-html port extras))))))) diff --git a/scheme/packages.scm b/scheme/packages.scm index 2e2c16e..6d5e182 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -3,10 +3,6 @@ ;;; This file is part of the Scheme Untergrund Networking package. -;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers. -;;; Copyright (c) 1996-2002 by Mike Sperber. -;;; Copyright (c) 2000-2002 by Martin Gasbichler. -;;; Copyright (c) 1998-2001 by Eric Marsden. ;;; For copyright information, see the file COPYING which comes with ;;; the distribution. @@ -330,7 +326,8 @@ version->string)) (define-interface httpd-responses-interface - (export make-response response? + (export http-version + make-response response? response-code response-message response-seconds