suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Contracts on stuff-url and removing unused args

Browse Source 
svn: r6377
This commit is contained in:
Jay McCarthy 2007-05-29 16:54:24 +00:00
parent 6305d748cf
commit d7c3c18c07
3 changed files with 24 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/web-server/prototype-web-server/private/stuff-url.ss
View File

@ -1,5 +1,7 @@
(module stuff-url mzscheme (module stuff-url mzscheme
(require (lib "url.ss" "net") (require (lib "contract.ss")
(lib "url.ss" "net")
(lib "serialize.ss")
"utils.ss" "utils.ss"
"mod-map.ss") "mod-map.ss")
@ -7,10 +9,11 @@
; XXX different ways to hash, different ways to store (maybe cookie?) ; XXX different ways to hash, different ways to store (maybe cookie?)
(provide stuff-url (provide/contract
stuffed-url? [stuff-url (serializable? url? . -> . url?)]
extend-url-query [stuffed-url? (url? . -> . boolean?)]
unstuff-url) [extend-url-query (url? symbol? string? . -> . url?)]
[unstuff-url (url? . -> . serializable?)])
; XXX Abstract this ; XXX Abstract this
(require (lib "md5.ss")) (require (lib "md5.ss"))
@ -27,9 +30,9 @@
(build-path (find-system-path 'home-dir) ".urls" (format "~a" hash)) (build-path (find-system-path 'home-dir) ".urls" (format "~a" hash))
(lambda () (read)))) (lambda () (read))))
;; stuff-url: serial url path -> url ;; stuff-url: serial url -> url
;; encode in the url ;; encode in the url
(define (stuff-url svl uri pth) (define (stuff-url svl uri)
(define result-uri (define result-uri
(extend-url-query uri 'c (md5-store (write/string (compress-serial svl))))) (extend-url-query uri 'c (md5-store (write/string (compress-serial svl)))))
(when (> (string-length (url->string result-uri)) (when (> (string-length (url->string result-uri))
@ -55,7 +58,7 @@
(url-query uri)) (url-query uri))
(url-fragment uri))) (url-fragment uri)))
;; unstuff-url: url url path -> serial ;; unstuff-url: url -> serial
;; decode from the url and reconstruct the 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))))))) (decompress-serial (read/string (md5-lookup (find-binding 'c (url-query req-url)))))))

18
collects/web-server/prototype-web-server/private/web.ss
View File

@ -52,8 +52,7 @@
(lambda (k) (lambda (k)
(page-maker (page-maker
(stuff-url (serialize k) (stuff-url (serialize k)
(session-url ses) (session-url ses)))))))
(session-mod-path ses)))))))
; XXX Changing embedding to be a param ; XXX Changing embedding to be a param
(define embed-label 'superkont) (define embed-label 'superkont)
@ -61,8 +60,7 @@
(define ses (current-session)) (define ses (current-session))
(define superkont-url (define superkont-url
(stuff-url (serialize proc) (stuff-url (serialize proc)
(session-url ses) (session-url ses)))
(session-mod-path ses)))
(define result-uri (define result-uri
(extend-url-query k-url embed-label (extend-url-query k-url embed-label
(url->string superkont-url))) (url->string superkont-url)))
@ -75,12 +73,10 @@
(define binds (url-query req-url)) (define binds (url-query req-url))
(define maybe-embedding (assq embed-label binds)) (define maybe-embedding (assq embed-label binds))
(if maybe-embedding (if maybe-embedding
(let* ([ses (current-session)] (let* ([superkont-url (string->url (cdr maybe-embedding))]
[superkont-url (string->url (cdr maybe-embedding))]
[proc (deserialize [proc (deserialize
(unstuff-url (unstuff-url
superkont-url (session-url ses) superkont-url))])
(session-mod-path ses)))])
(proc request)) (proc request))
(error 'send/suspend/dispatch "No ~a: ~S!" embed-label binds))) (error 'send/suspend/dispatch "No ~a: ~S!" embed-label binds)))
@ -89,13 +85,11 @@
(define (request->continuation req) (define (request->continuation req)
(or (or
; Look in url for c=<k> ; Look in url for c=<k>
(let* ([ses (current-session)] (let ([req-url (request-uri req)])
[req-url (request-uri req)])
(and (stuffed-url? req-url) (and (stuffed-url? req-url)
(deserialize (deserialize
(unstuff-url (unstuff-url
req-url (session-url ses) req-url))))
(session-mod-path ses)))))
; Look in query for kont=<k> ; Look in query for kont=<k>
(match (bindings-assq #"kont" (request-bindings/raw req)) (match (bindings-assq #"kont" (request-bindings/raw req))
[(struct binding:form (id kont)) [(struct binding:form (id kont))

12
collects/web-server/prototype-web-server/tests/stuff-url-tests.ss
View File

@ -14,9 +14,9 @@
(compress-serial (compress-serial
v))) v)))
(define (stuff-unstuff svl uri mod-path) (define (stuff-unstuff svl uri)
(let ([result-uri (stuff-url svl uri mod-path)]) (let ([result-uri (stuff-url svl uri)])
(unstuff-url result-uri uri mod-path))) (unstuff-url result-uri)))
(define the-dispatch (define the-dispatch
`(lambda (k*v) `(lambda (k*v)
@ -48,9 +48,9 @@
"compose stuff-url and unstuff-url and recover the serial" "compose stuff-url and unstuff-url and recover the serial"
(let-values ([(ev) (make-eval/mod-path m00)]) (let-values ([(ev) (make-eval/mod-path m00)])
(let* ([k0 (stuff-unstuff (ev '(serialize (dispatch-start start 'foo))) (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)))) [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)))) [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))))))))))) (check-true (= 6 (ev `(dispatch ,the-dispatch (list (deserialize ',k2) 3)))))))))))