From 4f4965883573d0fcc0e7dc9b5aff3c1e7e09d968 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Thu, 16 Sep 2010 12:41:44 -0600
Subject: [PATCH] Fixing problem reported by Robby.

Contracts intefere with safety marks.
---
 .../dispatchers/dispatch-lang-test.rkt          | 14 ++++++++++++++
 .../htdocs/lang-servlets/redirectget.rkt        | 17 +++++++++++++++++
 collects/web-server/lang/web.rkt                | 11 +++++------
 3 files changed, 36 insertions(+), 6 deletions(-)
 create mode 100644 collects/web-server/default-web-root/htdocs/lang-servlets/redirectget.rkt

diff --git a/collects/tests/web-server/dispatchers/dispatch-lang-test.rkt b/collects/tests/web-server/dispatchers/dispatch-lang-test.rkt
index 802a10af92..b7adcd37a7 100644
--- a/collects/tests/web-server/dispatchers/dispatch-lang-test.rkt
+++ b/collects/tests/web-server/dispatchers/dispatch-lang-test.rkt
@@ -161,4 +161,18 @@
                   "Quiz Results")
    
    ; XXX test web-extras.rkt - redirect/get
+   
+   (let* ([x (random 500)]
+          [xs (string->bytes/utf-8 (number->string x))]
+          [y (random 500)]
+          [ys (string->bytes/utf-8 (number->string y))])
+     (test-equal? 
+      "redirectget.rkt"
+      (let* ([d (mkd (build-path example-servlets "redirectget.rkt"))]
+             [k0 (simple-xpath* '(form #:action) (call d url0 empty))]
+             [k1 (call d k0 empty)])
+        k1)
+      ""))
+   
+   
    ))
diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/redirectget.rkt b/collects/web-server/default-web-root/htdocs/lang-servlets/redirectget.rkt
new file mode 100644
index 0000000000..5b8b514e5e
--- /dev/null
+++ b/collects/web-server/default-web-root/htdocs/lang-servlets/redirectget.rkt
@@ -0,0 +1,17 @@
+#lang web-server
+(define interface-version 'stateless)
+(provide start interface-version)
+
+(define (start request)
+  (define request 
+    (send/suspend
+     (λ (url)
+       `(html
+         (head)
+         (body
+          (form ((action ,url))
+                (input ((type "submit") (value "submit")))))))))
+  (redirect/get)
+  (send/suspend
+   (λ (_)
+     `(html "bye"))))
\ No newline at end of file
diff --git a/collects/web-server/lang/web.rkt b/collects/web-server/lang/web.rkt
index f13f07dd0a..4bf7f58d58 100644
--- a/collects/web-server/lang/web.rkt
+++ b/collects/web-server/lang/web.rkt
@@ -21,7 +21,8 @@
  send/suspend/dispatch
  send/suspend/hidden
  send/suspend/url
- send/suspend/url/dispatch)
+ send/suspend/url/dispatch
+ redirect/get)
 
 (provide/contract
  [make-stateless-servlet
@@ -37,7 +38,8 @@
    [send/suspend/hidden ((url? list? . -> . response/c) . -> . request?)]
    [send/suspend/url ((url? . -> . response/c) . -> . request?)]
    [send/suspend/url/dispatch ((((request? . -> . any/c) . -> . url?) . -> . response/c)
-                               . -> . any/c)])
+                               . -> . any/c)]
+   [redirect/get (-> request?)])
 
 ;; initial-servlet : (request -> response) -> (request -> response/c)
 (define (initialize-servlet start)
@@ -113,10 +115,7 @@
      [(struct binding:form (id kont))
       ((stuffer-out stuffer)
        (read (open-input-bytes kont)))]
-     [_ #f])))
-
-(provide/contract
- [redirect/get (-> request?)])  
+     [_ #f]))) 
 
 (define (redirect/get)
   (send/suspend/url (lambda (k-url) (redirect-to (url->string k-url) temporarily))))