Added type NO-BODY for responses which must not contain a message-body
(201, 304, 404). Added export of type-predicate no-body?. Adapted SEND-HTTP-RESPONSE to check for no-body responses. Extended MAKE-ERROR-RESPONSE to make responses 201, 304, 404.
This commit is contained in:
parent
0bb601a0e0
commit
44100cbf5e
|
@ -358,7 +358,8 @@
|
|||
(else
|
||||
(if (not (v0.9-request? request))
|
||||
(send-http-headers response output-port))
|
||||
(if (not (string=? (request-method request) "HEAD"))
|
||||
(if (not (or (string=? (request-method request) "HEAD")
|
||||
(no-body? (response-body response)))) ;; response messages which MUST NOT include a message-body
|
||||
(display-http-body (response-body response) input-port output-port options))
|
||||
(http-log request (response-code response)))))
|
||||
|
||||
|
|
|
@ -21,6 +21,12 @@
|
|||
;;representing the field value.
|
||||
(body response-body));; message-body
|
||||
|
||||
;;TODO: mime shouldn't be a field in http-response, because it needn't be present for
|
||||
;;responses which don't include a message-body.
|
||||
;;Instead treat mime-type like any other header.
|
||||
;;(Not urgent, as RFC 2616 doesn't prohibit presence of Content-Type header field
|
||||
;;in body-less responses).
|
||||
|
||||
;; This is mainly for nph-... CGI scripts.
|
||||
;; This means that the body will output the entire MIME message, not
|
||||
;; just the part after the headers.
|
||||
|
@ -50,6 +56,14 @@
|
|||
redirect-body?
|
||||
(location redirect-body-location))
|
||||
|
||||
;; type for responses which MUST NOT include a body (101, 204, 304)
|
||||
(define-enumerated-type no-body :no-body
|
||||
no-body?
|
||||
no-body-elements
|
||||
no-body-name
|
||||
no-body-index
|
||||
(none))
|
||||
|
||||
(define (display-http-body body iport oport options)
|
||||
(cond
|
||||
((writer-body? body)
|
||||
|
@ -165,17 +179,39 @@
|
|||
(format port "<br/>~%Further Information:~%"))
|
||||
(for-each (lambda (x) (format port "<br/>~%~s~%" x)) args)
|
||||
(format port "</p>~%</body>~%</html>~%")))
|
||||
|
||||
|
||||
(create-response
|
||||
(lambda (headers writer-proc)
|
||||
(lambda (headers body)
|
||||
(make-response code
|
||||
#f
|
||||
(time)
|
||||
"text/html"
|
||||
headers
|
||||
(make-writer-body writer-proc)))))
|
||||
body)))
|
||||
|
||||
(create-writer-body-response
|
||||
(lambda (headers writer-proc)
|
||||
(create-response headers (make-writer-body writer-proc))))
|
||||
|
||||
(create-no-body-response
|
||||
(lambda (headers)
|
||||
(create-response headers (no-body none)))))
|
||||
|
||||
(cond
|
||||
|
||||
;;this response requires one arg:
|
||||
;;the value of the Upgrade field header,
|
||||
;;which must be a string listing the protocols which are being switched
|
||||
;;for example "HTTP/2.0, IRC/6.9"
|
||||
((eq? code (status-code switch-protocol));; server currently doesn't have ability to switch protocols
|
||||
(assert 1)
|
||||
(create-no-body-response
|
||||
(list (cons 'upgrade (car extras))
|
||||
(cons 'connection "upgrade")))) ;; need this, because Upgrade header field only applies to immediate connection
|
||||
|
||||
((eq? code (status-code no-content))
|
||||
(create-no-body-response '()))
|
||||
|
||||
;; This error response requires one arg:
|
||||
;; the value of the Location field header,
|
||||
;; which must be a single absolute URI
|
||||
|
@ -184,7 +220,7 @@
|
|||
(eq? code (status-code temp-redirect));307
|
||||
(eq? code (status-code moved-perm)));301
|
||||
(assert 1)
|
||||
(create-response
|
||||
(create-writer-body-response
|
||||
(list (cons 'location (car extras)))
|
||||
(lambda (port options)
|
||||
(title-html port "Document moved")
|
||||
|
@ -196,8 +232,12 @@
|
|||
(car extras))
|
||||
(close-html port (cdr extras)))))
|
||||
|
||||
((eq? code (status-code not-mod))
|
||||
(create-no-body-response '())) ;;see RCF 2616 10.3.5: this is only a valid answer if the server never sends
|
||||
;;any of the headers Expires, Cache-Control, Vary for this resource
|
||||
|
||||
((eq? code (status-code bad-request))
|
||||
(create-response
|
||||
(create-writer-body-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(generic-title port)
|
||||
|
@ -210,7 +250,7 @@
|
|||
;; Ex.: "GET, HEAD, POST"
|
||||
((eq? code (status-code method-not-allowed))
|
||||
(assert 1)
|
||||
(create-response
|
||||
(create-writer-body-response
|
||||
(list (cons 'allow (car extras)))
|
||||
(lambda (port options)
|
||||
(generic-title port)
|
||||
|
@ -223,7 +263,7 @@
|
|||
;; which must be a challenge (as described in RFC 2617)
|
||||
((eq? code (status-code unauthorized))
|
||||
(assert 1)
|
||||
(create-response
|
||||
(create-writer-body-response
|
||||
(list (cons 'WWW-Authenticate (car extras)))
|
||||
(lambda (port options)
|
||||
(title-html port "Authentication Required")
|
||||
|
@ -231,7 +271,7 @@
|
|||
(close-html port (cdr extras)))))
|
||||
|
||||
((eq? code (status-code forbidden))
|
||||
(create-response
|
||||
(create-writer-body-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(title-html port "Request not allowed.")
|
||||
|
@ -239,7 +279,7 @@
|
|||
(close-html port extras))))
|
||||
|
||||
((eq? code (status-code not-found))
|
||||
(create-response
|
||||
(create-writer-body-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(title-html port "Resource not found")
|
||||
|
@ -248,7 +288,7 @@
|
|||
(close-html port extras))))
|
||||
|
||||
((eq? code (status-code internal-error))
|
||||
(create-response
|
||||
(create-writer-body-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(generic-title port)
|
||||
|
@ -258,7 +298,7 @@
|
|||
(close-html port extras))))
|
||||
|
||||
((eq? code (status-code not-implemented))
|
||||
(create-response
|
||||
(create-writer-body-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(generic-title port)
|
||||
|
@ -267,7 +307,7 @@
|
|||
(close-html port extras))))
|
||||
|
||||
((eq? code (status-code bad-gateway))
|
||||
(create-response
|
||||
(create-writer-body-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(generic-title port)
|
||||
|
|
|
@ -362,6 +362,7 @@
|
|||
make-writer-body writer-body?
|
||||
make-reader-writer-body reader-writer-body?
|
||||
make-redirect-body redirect-body? redirect-body-location
|
||||
no-body?
|
||||
display-http-body
|
||||
|
||||
status-code?
|
||||
|
|
Loading…
Reference in New Issue