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.
This commit is contained in:
interp 2002-09-02 13:42:10 +00:00
parent ae04e9e503
commit ff56fa6ec1
3 changed files with 60 additions and 10 deletions

View File

@ -156,11 +156,15 @@
(else
(decline))))
(lambda ()
(let* ((req (parse-http-request sock options))
(response ((httpd-options-path-handler options)
(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)))
(values req response)))))
(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)

View File

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

View File

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