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

@@ -156,11 +156,15 @@
 	    (else
 	     (decline))))
 	 (lambda ()
-	   (let* ((req (parse-http-request sock options))
+	   (let ((initial-req (parse-http-request sock options)))
-		  (response ((httpd-options-path-handler options)
+	     (let redirect-loop ((req initial-req))
-			     (http-url:path (request:url req))
+	       (let ((response ((httpd-options-path-handler options)
-			     req)))
+				(http-url:path (request:url req))
-	     (values req response)))))
+				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,
+;;; Parse the URL, but if it begins without the "http://host:port"
-;;; interpolate one from SOCKET. It would sleazier but faster if we just
+;;; prefix, interpolate one from SOCKET. It would be sleazier but
-;;; computed the default host and port at server-startup time, instead of
+;;; faster if we just computed the default host and port at
-;;; on every request.
+;;; 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)

scheme/httpd/response.scm

@@ -25,6 +25,11 @@
   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)
   (cond
@@ -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)))

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