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