From ff56fa6ec1bb5a75199f8a48c0468ca5862c6b1a Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Mon, 2 Sep 2002 13:42:10 +0000
Subject: [PATCH] Add redirection feature to web-server: If the handler returns
 with the return code HTTP-STATUS/REDIRECT, the server creates a new request
 out of the redirection response and recalls the handler to serve the request.
 You can use MAKE-REDIRECTION-RESPONSE to create this special response.

---
 scheme/httpd/core.scm     | 45 +++++++++++++++++++++++++++++++--------
 scheme/httpd/response.scm | 21 +++++++++++++++++-
 scheme/packages.scm       |  4 ++++
 3 files changed, 60 insertions(+), 10 deletions(-)

diff --git a/scheme/httpd/core.scm b/scheme/httpd/core.scm
index 5ac6c43..834b6b1 100644
--- a/scheme/httpd/core.scm
+++ b/scheme/httpd/core.scm
@@ -156,11 +156,15 @@
 	    (else
 	     (decline))))
 	 (lambda ()
-	   (let* ((req (parse-http-request sock options))
-		  (response ((httpd-options-path-handler options)
-			     (http-url:path (request:url req))
-			     req)))
-	     (values req response)))))
+	   (let ((initial-req (parse-http-request sock options)))
+	     (let redirect-loop ((req initial-req))
+	       (let ((response ((httpd-options-path-handler options)
+				(http-url:path (request:url req))
+				req)))
+	       (if (eq? (response-code response) 
+			http-status/redirect)
+		   (redirect-loop (redirect-request req response sock options))
+		   (values req response))))))))
       (lambda (req response)
 
 	(send-http-response req response 
@@ -170,6 +174,28 @@
 
 	(http-log req http-status/ok))))))
 
+(define (redirect-request req response socket options)
+  (let* ((new-location-uri (redirect-body-location (response-body response)))
+	 (url (with-fatal-error-handler*
+	       (lambda (c decline)
+		 (if (fatal-syntax-error? c)
+		     (http-error http-status/internal-error req
+				 (format #f "Bad redirection out from CGI program: ~%~a"
+					 (cdr c)))
+		     (decline c)))
+	       (lambda ()
+		 ;; (future) NOTE: With this, a redirection may change the
+		 ;; protocol in use (currently, the server only supports one of
+		 ;; it). This might be inapplicable.
+		 (parse-http-servers-url-fragment new-location-uri socket options)))))
+    
+    (make-request "GET"
+		  new-location-uri
+		  url
+		  (request:version req)	; did not change
+		  '()			; no rfc822 headers
+		  (request:socket req))))
+
 ;;;; HTTP request parsing
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; This code provides procedures to read requests from an input
@@ -214,10 +240,11 @@
 
 		
 
-;;; Parse the URL, but if it begins without the "http://host:port" prefix,
-;;; interpolate one from SOCKET. It would sleazier but faster if we just
-;;; computed the default host and port at server-startup time, instead of
-;;; on every request.
+;;; Parse the URL, but if it begins without the "http://host:port"
+;;; prefix, interpolate one from SOCKET. It would be sleazier but
+;;; faster if we just computed the default host and port at
+;;; server-startup time, instead of on every request.
+;;; REDIRECT-REQUEST relys on that nothing is read out from SOCKET.
 
 (define (parse-http-servers-url-fragment uri-string socket options)
   (receive (scheme path search frag-id) (parse-uri uri-string)
diff --git a/scheme/httpd/response.scm b/scheme/httpd/response.scm
index c558ee7..499e2d0 100644
--- a/scheme/httpd/response.scm
+++ b/scheme/httpd/response.scm
@@ -24,6 +24,11 @@
   (make-reader-writer-body proc)
   reader-writer-body?
   (proc reader-writer-body-proc))
+
+(define-record-type :http-redirect-body
+  (make-redirect-body location)
+  redirect-body?
+  (location redirect-body-location))
 			   
 
 (define (display-http-body body iport oport options)
@@ -70,7 +75,9 @@
   (not-implemented	501 "Not Implemented")
   (bad-gateway		502 "Bad Gateway")
   (service-unavailable	503 "Service Unavailable")
-  (gateway-timeout	504 "Gateway Timeout"))
+  (gateway-timeout	504 "Gateway Timeout")
+  
+  (redirect             -301 "Internal redirect"))
 	
 (define (status-code->text code)
   (cdr (assv code http-status-text-table)))
@@ -204,3 +211,15 @@ the requested method (~A).~%"
 
 (define (time->http-date-string time)
   (format-date "~A, ~d-~b-~y ~H:~M:~S GMT" (date time 0)))
+
+
+;; Creates a redirect response. The server will serve the new file indicated by
+;; NEW-LOCATION. NEW-LOCATION must be uri-encoded and begin with a slash.
+(define (make-redirect-response new-location)
+  (make-response
+   http-status/redirect
+   (status-code->text http-status/redirect)
+   (time)
+   ""
+   '()
+   (make-redirect-body new-location)))
\ No newline at end of file
diff --git a/scheme/packages.scm b/scheme/packages.scm
index edecd66..e055c98 100644
--- a/scheme/packages.scm
+++ b/scheme/packages.scm
@@ -321,6 +321,7 @@
 
 	  make-writer-body writer-body?
 	  make-reader-writer-body reader-writer-body?
+	  make-redirect-body redirect-body? redirect-body-location
 	  display-http-body
 
 	  ;; Integer reply codes
@@ -351,8 +352,10 @@
 	  http-status/bad-gateway
 	  http-status/service-unavailable
 	  http-status/gateway-timeout
+	  http-status/redirect		; used internally
 
 	  make-http-error-response
+	  make-redirect-response
 	  time->http-date-string))
 
 (define-interface httpd-basic-handlers-interface
@@ -850,6 +853,7 @@
 	format-net              ; FORMAT-INTERNET-HOST-ADDRESS
 	sunet-utilities         ; host-name-or-empty
 	let-opt                 ; let-optionals
+	handle-fatal-error
 	scheme)
   (files (httpd cgi-server)))