diff --git a/collects/web-server/prototype-web-server/private/stuff-url.ss b/collects/web-server/prototype-web-server/private/stuff-url.ss index 4a4f732936..8b04de9b4a 100644 --- a/collects/web-server/prototype-web-server/private/stuff-url.ss +++ b/collects/web-server/prototype-web-server/private/stuff-url.ss @@ -1,5 +1,7 @@ (module stuff-url mzscheme - (require (lib "url.ss" "net") + (require (lib "contract.ss") + (lib "url.ss" "net") + (lib "serialize.ss") "utils.ss" "mod-map.ss") @@ -7,10 +9,11 @@ ; XXX different ways to hash, different ways to store (maybe cookie?) - (provide stuff-url - stuffed-url? - extend-url-query - unstuff-url) + (provide/contract + [stuff-url (serializable? url? . -> . url?)] + [stuffed-url? (url? . -> . boolean?)] + [extend-url-query (url? symbol? string? . -> . url?)] + [unstuff-url (url? . -> . serializable?)]) ; XXX Abstract this (require (lib "md5.ss")) @@ -27,9 +30,9 @@ (build-path (find-system-path 'home-dir) ".urls" (format "~a" hash)) (lambda () (read)))) - ;; stuff-url: serial url path -> url + ;; stuff-url: serial url -> url ;; encode in the url - (define (stuff-url svl uri pth) + (define (stuff-url svl uri) (define result-uri (extend-url-query uri 'c (md5-store (write/string (compress-serial svl))))) (when (> (string-length (url->string result-uri)) @@ -55,7 +58,7 @@ (url-query uri)) (url-fragment uri))) - ;; unstuff-url: url url path -> serial + ;; unstuff-url: url -> serial ;; decode from the url and reconstruct the serial - (define (unstuff-url req-url ses-url mod-path) + (define (unstuff-url req-url) (decompress-serial (read/string (md5-lookup (find-binding 'c (url-query req-url))))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/private/web.ss b/collects/web-server/prototype-web-server/private/web.ss index f0d4f10783..cb7e25b8e4 100644 --- a/collects/web-server/prototype-web-server/private/web.ss +++ b/collects/web-server/prototype-web-server/private/web.ss @@ -52,8 +52,7 @@ (lambda (k) (page-maker (stuff-url (serialize k) - (session-url ses) - (session-mod-path ses))))))) + (session-url ses))))))) ; XXX Changing embedding to be a param (define embed-label 'superkont) @@ -61,8 +60,7 @@ (define ses (current-session)) (define superkont-url (stuff-url (serialize proc) - (session-url ses) - (session-mod-path ses))) + (session-url ses))) (define result-uri (extend-url-query k-url embed-label (url->string superkont-url))) @@ -75,12 +73,10 @@ (define binds (url-query req-url)) (define maybe-embedding (assq embed-label binds)) (if maybe-embedding - (let* ([ses (current-session)] - [superkont-url (string->url (cdr maybe-embedding))] + (let* ([superkont-url (string->url (cdr maybe-embedding))] [proc (deserialize (unstuff-url - superkont-url (session-url ses) - (session-mod-path ses)))]) + superkont-url))]) (proc request)) (error 'send/suspend/dispatch "No ~a: ~S!" embed-label binds))) @@ -89,13 +85,11 @@ (define (request->continuation req) (or ; Look in url for c= - (let* ([ses (current-session)] - [req-url (request-uri req)]) + (let ([req-url (request-uri req)]) (and (stuffed-url? req-url) (deserialize (unstuff-url - req-url (session-url ses) - (session-mod-path ses))))) + req-url)))) ; Look in query for kont= (match (bindings-assq #"kont" (request-bindings/raw req)) [(struct binding:form (id kont)) diff --git a/collects/web-server/prototype-web-server/tests/stuff-url-tests.ss b/collects/web-server/prototype-web-server/tests/stuff-url-tests.ss index 9e0f9d1095..ddf64799db 100644 --- a/collects/web-server/prototype-web-server/tests/stuff-url-tests.ss +++ b/collects/web-server/prototype-web-server/tests/stuff-url-tests.ss @@ -14,9 +14,9 @@ (compress-serial v))) - (define (stuff-unstuff svl uri mod-path) - (let ([result-uri (stuff-url svl uri mod-path)]) - (unstuff-url result-uri uri mod-path))) + (define (stuff-unstuff svl uri) + (let ([result-uri (stuff-url svl uri)]) + (unstuff-url result-uri))) (define the-dispatch `(lambda (k*v) @@ -48,9 +48,9 @@ "compose stuff-url and unstuff-url and recover the serial" (let-values ([(ev) (make-eval/mod-path m00)]) (let* ([k0 (stuff-unstuff (ev '(serialize (dispatch-start start 'foo))) - uri0 m00)] + uri0)] [k1 (stuff-unstuff (ev `(serialize (dispatch ,the-dispatch (list (deserialize ',k0) 1)))) - uri0 m00)] + uri0)] [k2 (stuff-unstuff (ev `(serialize (dispatch ,the-dispatch (list (deserialize ',k1) 2)))) - uri0 m00)]) + uri0)]) (check-true (= 6 (ev `(dispatch ,the-dispatch (list (deserialize ',k2) 3))))))))))) \ No newline at end of file