From ce4c6fac3869f671ddc7b46f8b1e7199555e92d2 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Wed, 30 May 2007 15:19:44 +0000
Subject: [PATCH] Adding support for additional headers with redirect-to

svn: r6403
---
 .../web-server/dispatchers/dispatch-files.ss  |  1 +
 .../dispatchers/dispatch-servlets.ss          |  1 +
 .../web-server/private/servlet-helpers.ss     | 19 +++++++++++--------
 .../dispatch-servlets2.ss                     |  1 +
 4 files changed, 14 insertions(+), 8 deletions(-)

diff --git a/collects/web-server/dispatchers/dispatch-files.ss b/collects/web-server/dispatchers/dispatch-files.ss
index b29b922799..97232a6c3d 100644
--- a/collects/web-server/dispatchers/dispatch-files.ss
+++ b/collects/web-server/dispatchers/dispatch-files.ss
@@ -52,6 +52,7 @@
       ;; serve-file : connection symbol uri host -> void
       ;; to find the file, including searching for implicit index files, and serve it out
       (define path 
+        ; XXX Abstract this
         (url-path->path htdocs-path
                         (uri-decode (url-path->string (url-path uri)))))
       (cond
diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss
index ffecec5e6d..5fe8abcb2f 100644
--- a/collects/web-server/dispatchers/dispatch-servlets.ss
+++ b/collects/web-server/dispatchers/dispatch-servlets.ss
@@ -116,6 +116,7 @@
                             (raise (make-exn:fail:filesystem:exists:servlet
                                     (exn-message e)
                                     (exn-continuation-marks e))))])
+                 ; XXX Abstract this
                  (url-path->path
                   servlet-root
                   (url-path->string (url-path uri)))))
diff --git a/collects/web-server/private/servlet-helpers.ss b/collects/web-server/private/servlet-helpers.ss
index 8d3bed700e..ab6110b032 100644
--- a/collects/web-server/private/servlet-helpers.ss
+++ b/collects/web-server/private/servlet-helpers.ss
@@ -1,6 +1,6 @@
 (module servlet-helpers mzscheme
   (require (lib "contract.ss")
-           (lib "etc.ss")
+           (lib "kw.ss")
            (lib "plt-match.ss")
            (lib "base64.ss" "net")
            (lib "uri-codec.ss" "net"))
@@ -36,12 +36,15 @@
   (define see-other (make-redirection-status 303 "See Other"))
   
   ; : str [redirection-status] -> response
-  (define redirect-to
-    (opt-lambda (uri [perm/temp permanently])
-      (make-response/full (redirection-status-code perm/temp)
-                          (redirection-status-message perm/temp)
-                          (current-seconds) #"text/html"
-                          `((Location . ,uri)) (list))))
+  (define/kw (redirect-to uri
+                          #:optional
+                          [perm/temp permanently]
+                          #:key
+                          [headers (list)])
+    (make-response/full (redirection-status-code perm/temp)
+                        (redirection-status-message perm/temp)
+                        (current-seconds) #"text/html"
+                        `((Location . ,uri) ,@headers) (list)))
   
   ; with-errors-to-browser 
   ; to report exceptions that occur later to the browser
@@ -87,11 +90,11 @@
   
   (provide ; all-from
    with-errors-to-browser
+   redirect-to
    (rename uri-decode translate-escapes))
   (provide/contract
    ; XXX contract maybe   
    [extract-user-pass ((listof header?) . -> . (or/c false/c (cons/c bytes? bytes?)))]
-   [redirect-to ((string?) (redirection-status?) . opt-> . response/full?)]
    [permanently redirection-status?]
    [temporarily redirection-status?]
    [see-other redirection-status?]
diff --git a/collects/web-server/prototype-web-server/dispatch-servlets2.ss b/collects/web-server/prototype-web-server/dispatch-servlets2.ss
index 5134d0b941..89c7bfeeb2 100644
--- a/collects/web-server/prototype-web-server/dispatch-servlets2.ss
+++ b/collects/web-server/prototype-web-server/dispatch-servlets2.ss
@@ -65,6 +65,7 @@
     (define (begin-session conn req)
       (define uri (request-uri req))
       (define-values (a-path url-servlet-path url-path-suffix)
+        ; XXX Abstract this, so they don't need to live on disk.
         (url->servlet-path htdocs-path uri))
       (if a-path
           (parameterize ([current-directory (directory-part a-path)])