answer 505 (Version not supported) for requests with major version >

implemented version:
*new proc CHECK-MAJOR-HTTP-VERSION
*new case in MAKE-ERROR-RESPONSE
This commit is contained in:
vibr 2005-04-13 19:35:22 +00:00
parent fe6b3fffac
commit 40d7c923a2
3 changed files with 37 additions and 28 deletions

View File

@ -2,10 +2,6 @@
;;; This file is part of the Scheme Untergrund Networking package. ;;; 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 ;;; For copyright information, see the file COPYING which comes with
;;; the distribution. ;;; the distribution.
@ -17,11 +13,17 @@
;;; a complete server, you need to define request handlers (see below) -- ;;; a complete server, you need to define request handlers (see below) --
;;; they determine how requests are to be handled. ;;; they determine how requests are to be handled.
;;; ;;;
;;; The RFC detailing the HTTP 1.0 protocol, RFC 1945, can be found at ;;; See RFC 2616 for the specification of the HTTP/1.1 protocol.
;;; http://www.w3.org/Protocols/rfc1945/rfc1945 ;;;
;;; 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 http-version-string
(define server/protocol "HTTP/1.0") (string-append "HTTP/"
(number->string (car http-version))
"."
(number->string (cdr http-version))))
(define (httpd options) (define (httpd options)
(let ((port (httpd-options-port options)) (let ((port (httpd-options-port options))
@ -168,6 +170,7 @@
(decline)))) (decline))))
(lambda () (lambda ()
(let ((initial-req (parse-http-request sock options))) (let ((initial-req (parse-http-request sock options)))
(check-major-http-version initial-req)
(let redirect-loop ((req initial-req)) (let redirect-loop ((req initial-req))
(let response-loop ((response ((httpd-options-request-handler options) (let response-loop ((response ((httpd-options-request-handler options)
(http-url-path (request-url req)) (http-url-path (request-url req))
@ -216,18 +219,7 @@
'() ; no rfc822 headers '() ; no rfc822 headers
(request-socket req)))) (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. ;;; 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) (define (parse-http-request sock options)
(let ((line (read-crlf-line (socket:inport sock)))) (let ((line (read-crlf-line (socket:inport sock))))
@ -270,6 +262,14 @@
(lose vstring)))))) (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. ;;; Split string into a list of whitespace-separated strings.
;;; This could have been trivially defined in scsh as (field-splitter " \t\n") ;;; 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 ;;; but I hand-coded it because it's short, and I didn't want invoke the
@ -289,7 +289,7 @@
(else '())))) (else '()))))
(define (send-http-headers response port) (define (send-http-headers response port)
(display server/protocol port) (display http-version-string port)
(write-char #\space port) (write-char #\space port)
(display (status-code-number (response-code response)) port) (display (status-code-number (response-code response)) port)
(write-char #\space port) (write-char #\space port)

View File

@ -1,10 +1,10 @@
;;; This file is part of the Scheme Untergrund Networking package. ;;; 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 ;;; For copyright information, see the file COPYING which comes with
;;; the distribution. ;;; the distribution.
(define http-version '(1 . 1));server's HTTP-version is only hardcoded here!
(define-record-type http-response :http-response (define-record-type http-response :http-response
(make-response code message seconds mime extras body) (make-response code message seconds mime extras body)
response? response?
@ -312,6 +312,18 @@
(lambda (port options) (lambda (port options)
(generic-title port) (generic-title port)
(format port "This server received an invalid response from the upstream server it accessed in attempting to fulfill the request.~%") (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))))))) (close-html port extras)))))))

View File

@ -3,10 +3,6 @@
;;; This file is part of the Scheme Untergrund Networking package. ;;; 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 ;;; For copyright information, see the file COPYING which comes with
;;; the distribution. ;;; the distribution.
@ -330,7 +326,8 @@
version->string)) version->string))
(define-interface httpd-responses-interface (define-interface httpd-responses-interface
(export make-response response? (export http-version
make-response response?
response-code response-code
response-message response-message
response-seconds response-seconds