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.

scheme/httpd/core.scm

@@ -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)))))
 

scheme/httpd/response.scm

@@ -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)

scheme/packages.scm

@@ -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?