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:
parent
fe6b3fffac
commit
40d7c923a2
|
@ -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)
|
||||||
|
|
|
@ -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)))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue