From 880a05229c81244934cc5d65c112dbf6f7c09b99 Mon Sep 17 00:00:00 2001
From: vibr <vibr>
Date: Wed, 11 Aug 2004 14:51:51 +0000
Subject: [PATCH] -adapt calls of make-error-response -allow header in 405
 answers -answer 501, not 405, for unimplemented/unrecognized methods

---
 scheme/httpd/file-dir-handler.scm | 15 ++++++++++-----
 scheme/httpd/info-gateway.scm     |  8 +++++---
 scheme/httpd/rman-gateway.scm     |  8 ++++++--
 scheme/httpd/seval.scm            |  7 ++++++-
 4 files changed, 27 insertions(+), 11 deletions(-)

diff --git a/scheme/httpd/file-dir-handler.scm b/scheme/httpd/file-dir-handler.scm
index e5e1fdd..0da6cc6 100644
--- a/scheme/httpd/file-dir-handler.scm
+++ b/scheme/httpd/file-dir-handler.scm
@@ -259,9 +259,11 @@
 
 	      (else (make-error-response (status-code forbidden) req)))))
 	 
-	 (else 
+	 ((string=? request-method "POST")
 	  (make-error-response (status-code method-not-allowed) req 
-			       request-method))))))
+			        "GET, HEAD"))
+	 (else 
+	  (make-error-response (status-code not-implemented) req))))))
 
 (define (directory-index-serve-response fname file-path req options)
   (file-serve-response (string-append fname "index.html") file-path req options))
@@ -445,9 +447,12 @@
 			(let ((n-files (directory-index req fname port options)))
 			  (emit-tag port 'hr)
 			  (format port "~d files" n-files))))))))))))
-     (else
-      (make-error-response (status-code method-not-allowed) req 
-			   request-method)))))
+	 
+	 ((string=? request-method "POST")
+	  (make-error-response (status-code method-not-allowed) req 
+			       "GET, HEAD"))
+	 (else 
+	  (make-error-response (status-code not-implemented) req)))))
 
 (define (index-or-directory-serve-response fname file-path req options)
   (let ((index-fname (string-append fname "index.html")))
diff --git a/scheme/httpd/info-gateway.scm b/scheme/httpd/info-gateway.scm
index 40dc5df..93be76e 100644
--- a/scheme/httpd/info-gateway.scm
+++ b/scheme/httpd/info-gateway.scm
@@ -172,10 +172,12 @@
 			       out))
 	       (with-tag out address ()
 		 (write-string address out)))))))
-
-	 (else 
+	 ((or (string=? request-method "HEAD")
+	      (string=? request-method "POST"))
 	  (make-error-response (status-code method-not-allowed) req 
-				    request-method)))))))
+				    "GET"))
+	 (else
+	  (make-error-response (status-code not-implemented) req)))))))
 
 (define split-header-line
   (let ((split (infix-splitter (make-regexp "(, *)|(  +)|( *\t *)")))
diff --git a/scheme/httpd/rman-gateway.scm b/scheme/httpd/rman-gateway.scm
index cacdbc2..727b5b9 100644
--- a/scheme/httpd/rman-gateway.scm
+++ b/scheme/httpd/rman-gateway.scm
@@ -70,9 +70,13 @@
 	       
 	       (with-tag out address ()
 		 (display address out)))))))
-	 (else 
+	 ((or (string=? request-method "HEAD")
+	      (string=? request-method "POST"))
 	  (make-error-response (status-code method-not-allowed) req 
-				    request-method)))))))
+			       "GET"))
+	 (else
+	  (make-error-response (status-code not-implemented) req)))))))
+
 
 (define (cat-man-page key section out)
   (let ((title (if section
diff --git a/scheme/httpd/seval.scm b/scheme/httpd/seval.scm
index bfd3421..a1efc5c 100644
--- a/scheme/httpd/seval.scm
+++ b/scheme/httpd/seval.scm
@@ -38,8 +38,13 @@
     (cond 
      ((string=? request-method "POST")	; Could do others also.
       (seval path req))
+     ((or (string=? request-method "HEAD")
+	  (string=? request-method "GET"))
+      (make-error-response (status-code method-not-allowed) req 
+				    "POST"))
      (else
-      (make-error-response (status-code method-not-allowed) req request-method)))))
+      (make-error-response (status-code not-implemented) req)))))
+
 
 (define (seval path req)
     (make-response