diff --git a/collects/web-server/dispatchers/dispatch-lang.ss b/collects/web-server/dispatchers/dispatch-lang.ss index 5eade3eac5..40fa0c71a7 100644 --- a/collects/web-server/dispatchers/dispatch-lang.ss +++ b/collects/web-server/dispatchers/dispatch-lang.ss @@ -45,7 +45,8 @@ new-path) empty #f)) - + + ;; XXX url->servlet, get rid of timeout, optional session manager (define interface-version 'v1) (define/kw (make #:key url->path diff --git a/collects/web-server/servlet/servlet-url.ss b/collects/web-server/servlet/servlet-url.ss index 9200fb2658..dea37fdf35 100644 --- a/collects/web-server/servlet/servlet-url.ss +++ b/collects/web-server/servlet/servlet-url.ss @@ -14,9 +14,11 @@ (lambda (ps) (map (lambda (p/p) (if (unbox first?) - (make-path/param (path/param-path p/p) empty) + (begin0 (make-path/param (path/param-path p/p) empty) + (set-box! first? #f)) p/p)) - ps))))) + ps)) + in-url))) (define (request->servlet-url req) (make-servlet-url (request-uri req))) diff --git a/collects/web-server/tests/servlet/servlet-url-test.ss b/collects/web-server/tests/servlet/servlet-url-test.ss index b9e622b1a8..26f8c86740 100644 --- a/collects/web-server/tests/servlet/servlet-url-test.ss +++ b/collects/web-server/tests/servlet/servlet-url-test.ss @@ -1,8 +1,29 @@ (module servlet-url-test mzscheme - (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))) + (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) + (lib "list.ss") + (lib "url.ss" "net") + (lib "servlet-url.ss" "web-server" "servlet") + (lib "request-structs.ss" "web-server" "private")) (provide servlet-url-tests) - ; XXX (define servlet-url-tests (test-suite - "Servlet URLs"))) \ No newline at end of file + "Servlet URLs" + + (test-case + "Basic" + (check-equal? (servlet-url->url-string/no-continuation + (request->servlet-url + (make-request 'get (string->url "http://localhost/servlets;1*1*65539753/examples/add.ss") + empty empty #f + "host" 80 "client"))) + "http://localhost/servlets/examples/add.ss")) + + (test-case + "Param" + (check-equal? (servlet-url->url-string/no-continuation + (request->servlet-url + (make-request 'get (string->url "http://localhost/servlets;1*1*65539753/examples/add.ss;foo") + empty empty #f + "host" 80 "client"))) + "http://localhost/servlets/examples/add.ss;foo"))))) \ No newline at end of file