Contracts, tests, and rearranging
svn: r6374
This commit is contained in:
Jay McCarthy
parent
2ceb6f181f
commit
a18d5bb243
58
collects/web-server/prototype-web-server/private/mod-map.ss
Normal file
58
collects/web-server/prototype-web-server/private/mod-map.ss
Normal file
|
|
@ -0,0 +1,58 @@
|
|||
(module mod-map mzscheme
|
||||
(require (lib "list.ss")
|
||||
(lib "plt-match.ss"))
|
||||
(provide compress-serial
|
||||
decompress-serial)
|
||||
|
||||
; XXX even though we allow all values to be serialized, we only protect against source modification of the servlet program.
|
||||
|
||||
;; compress-mod-map : (listof (cons mod-spec symbol)) -> (listof (cons (or mod-spec number) symbol))
|
||||
(define (compress-mod-map mm)
|
||||
(compress-mod-map/seen empty mm))
|
||||
|
||||
(define (lookup-seen ms seen)
|
||||
(match seen
|
||||
[(list)
|
||||
(values #f (list ms))]
|
||||
[(list-rest ms+ seen+)
|
||||
(if (equal? ms ms+)
|
||||
(values 0 (list* ms+ seen+))
|
||||
(let-values ([(i seen++) (lookup-seen ms seen+)])
|
||||
(values (if i (add1 i) #f) (list* ms+ seen++))))]))
|
||||
|
||||
(define (compress-mod-map/seen seen mm)
|
||||
(match mm
|
||||
[(list)
|
||||
(list)]
|
||||
[(list-rest (list-rest mod-spec sym) mm)
|
||||
(define-values (i seen+) (lookup-seen mod-spec seen))
|
||||
(if i
|
||||
(list* (cons i sym) (compress-mod-map/seen seen+ mm))
|
||||
(list* (cons mod-spec sym) (compress-mod-map/seen seen+ mm)))]))
|
||||
|
||||
;; decompress-mod-map : (listof (cons (or mod-spec number) symbol)) -> (listof (cons mod-spec symbol))
|
||||
(define (decompress-mod-map cmm)
|
||||
(decompress-mod-map/seen empty cmm))
|
||||
|
||||
(define (decompress-mod-map/seen seen cmm)
|
||||
(match cmm
|
||||
[(list)
|
||||
(list)]
|
||||
[(list-rest (list-rest mod-spec-or-n sym) cmm)
|
||||
(if (number? mod-spec-or-n)
|
||||
(list* (cons (list-ref seen mod-spec-or-n) sym)
|
||||
(decompress-mod-map/seen seen cmm))
|
||||
(list* (cons mod-spec-or-n sym)
|
||||
(decompress-mod-map/seen (append seen (list mod-spec-or-n)) cmm)))]))
|
||||
|
||||
; compress-serial : serial -> serial (with compressed mod-map)
|
||||
(define compress-serial
|
||||
(match-lambda
|
||||
[(list e0 mm e2 e3 e4 e5)
|
||||
(list e0 (compress-mod-map mm) e2 e3 e4 e5)]))
|
||||
|
||||
; decompress-serial : serial (with compressed mod-map) -> serial
|
||||
(define decompress-serial
|
||||
(match-lambda
|
||||
[(list e0 cmm e2 e3 e4 e5)
|
||||
(list e0 (decompress-mod-map cmm) e2 e3 e4 e5)])))
|
||||
|
|
@ -1,204 +1,15 @@
|
|||
(module stuff-url mzscheme
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "list.ss")
|
||||
(lib "plt-match.ss")
|
||||
"utils.ss")
|
||||
|
||||
; XXX even though we allow all values to be serialized, we only protect against source modification of the servlet program.
|
||||
"utils.ss"
|
||||
"mod-map.ss")
|
||||
|
||||
; XXX url: first try continuation, then turn into hash
|
||||
|
||||
; XXX different ways to hash, different ways to store (maybe cookie?)
|
||||
|
||||
;; ****************************************
|
||||
;; URL LAYOUT
|
||||
|
||||
;; The mod-map will be encoded in the URL path. The graph, fixups and serial will be
|
||||
;; encoded in the query.
|
||||
|
||||
;; The first path element following the servlet file-name will be the labeling code.
|
||||
|
||||
;; The remaining path elements will encode the mod-map, now represented as a list of
|
||||
;; numbers.
|
||||
|
||||
;; The query will contain bindings for at least one and as many as three keys:
|
||||
|
||||
;; g -- the graph
|
||||
;; f -- the fixups
|
||||
;; v -- the main serial value.
|
||||
|
||||
;; If the graph and fixups are trivial, then they will be omitted from the query.
|
||||
|
||||
|
||||
(provide stuff-url
|
||||
extend-url-query
|
||||
unstuff-url
|
||||
find-binding)
|
||||
|
||||
;; compress-mod-map : (listof (cons mod-spec symbol)) -> (listof (cons (or mod-spec number) symbol))
|
||||
(define (compress-mod-map mm)
|
||||
(compress-mod-map/seen empty mm))
|
||||
|
||||
(define (lookup-seen ms seen)
|
||||
(match seen
|
||||
[(list)
|
||||
(values #f (list ms))]
|
||||
[(list-rest ms+ seen+)
|
||||
(if (equal? ms ms+)
|
||||
(values 0 (list* ms+ seen+))
|
||||
(let-values ([(i seen++) (lookup-seen ms seen+)])
|
||||
(values (if i (add1 i) #f) (list* ms+ seen++))))]))
|
||||
|
||||
(define (compress-mod-map/seen seen mm)
|
||||
(match mm
|
||||
[(list)
|
||||
(list)]
|
||||
[(list-rest (list-rest mod-spec sym) mm)
|
||||
(define-values (i seen+) (lookup-seen mod-spec seen))
|
||||
(if i
|
||||
(list* (cons i sym) (compress-mod-map/seen seen+ mm))
|
||||
(list* (cons mod-spec sym) (compress-mod-map/seen seen+ mm)))]))
|
||||
|
||||
;; decompress-mod-map : (listof (cons (or mod-spec number) symbol)) -> (listof (cons mod-spec symbol))
|
||||
(define (decompress-mod-map cmm)
|
||||
(decompress-mod-map/seen empty cmm))
|
||||
|
||||
(define (decompress-mod-map/seen seen cmm)
|
||||
(match cmm
|
||||
[(list)
|
||||
(list)]
|
||||
[(list-rest (list-rest mod-spec-or-n sym) cmm)
|
||||
(if (number? mod-spec-or-n)
|
||||
(list* (cons (list-ref seen mod-spec-or-n) sym)
|
||||
(decompress-mod-map/seen seen cmm))
|
||||
(list* (cons mod-spec-or-n sym)
|
||||
(decompress-mod-map/seen (append seen (list mod-spec-or-n)) cmm)))]))
|
||||
|
||||
; compress-serial : serial -> serial (with compressed mod-map)
|
||||
(define compress-serial
|
||||
(match-lambda
|
||||
[(list e0 mm e2 e3 e4 e5)
|
||||
(list e0 (compress-mod-map mm) e2 e3 e4 e5)]))
|
||||
|
||||
; decompress-serial : serial (with compressed mod-map) -> serial
|
||||
(define decompress-serial
|
||||
(match-lambda
|
||||
[(list e0 cmm e2 e3 e4 e5)
|
||||
(list e0 (decompress-mod-map cmm) e2 e3 e4 e5)]))
|
||||
|
||||
;; url-parts: module-path serial -> string (listof (union number 'k)) s-expr s-expr s-expr
|
||||
;; compute the parts for the url:
|
||||
;; labeling code
|
||||
;; simplified mod-map encoding
|
||||
;; graph
|
||||
;; fixups
|
||||
;; main serial
|
||||
(define (url-parts mod-path sv)
|
||||
(let* ([mod-map (cadr sv)]
|
||||
[lab-code (get-labeling-code mod-path mod-map)]
|
||||
[simple-map (simplify-module-map mod-path lab-code mod-map)])
|
||||
(values lab-code simple-map
|
||||
(list-ref sv 3)
|
||||
(list-ref sv 4)
|
||||
(list-ref sv 5))))
|
||||
|
||||
;; recover-serial: module-path (listof (union number 'k)) s-expr s-expr s-expr -> serial
|
||||
;; recover the serializable value from parts
|
||||
(define (recover-serial mod-path label-code simple-map graph fixups main-serial)
|
||||
(list (length simple-map)
|
||||
(reconstruct-mod-map mod-path label-code simple-map)
|
||||
(length graph)
|
||||
graph fixups main-serial))
|
||||
|
||||
;; reconstruct-mod-map: module-path string (listof (union number 'k)) -> module-map
|
||||
;; reconstruct the module map from the simple map
|
||||
(define (reconstruct-mod-map mod-path label-code simple-map)
|
||||
(map
|
||||
(lambda (n-or-k)
|
||||
(if (symbol? n-or-k)
|
||||
`((lib "abort-resume.ss" "web-server" "prototype-web-server" "private") . ,n-or-k)
|
||||
(cons
|
||||
mod-path
|
||||
(string->symbol
|
||||
(format "web-deserialize-info:~a~a"
|
||||
label-code
|
||||
n-or-k)))))
|
||||
simple-map))
|
||||
|
||||
;; get-labeling-code: module-path module-map -> string
|
||||
;; pull the labeling code out of the module map
|
||||
(define (get-labeling-code pth mod-map)
|
||||
(let loop ([mod-map mod-map])
|
||||
(cond
|
||||
[(null? mod-map)
|
||||
(error "couldn't find labeling code")]
|
||||
[(and (same-module? pth (caar mod-map))
|
||||
(match-labeling-code (cdar mod-map)))
|
||||
=> (lambda (lcode) lcode)]
|
||||
[else (loop (cdr mod-map))])))
|
||||
|
||||
(define WEB-DESERIALIZE-INFO-REGEXP (regexp "web-deserialize-info:([a-zA-Z]*)(.*)"))
|
||||
;; match-labeling-code: symbol -> string
|
||||
;; pull the labeling code out of the symbol
|
||||
(define (match-labeling-code sym)
|
||||
(let ([match? (regexp-match WEB-DESERIALIZE-INFO-REGEXP (symbol->string sym))])
|
||||
(and match? (cadr match?))))
|
||||
|
||||
;; match-label: symbol -> number
|
||||
;; pull the closure number out of the symbol
|
||||
(define (match-label sym)
|
||||
(let ([match? (regexp-match WEB-DESERIALIZE-INFO-REGEXP (symbol->string sym))])
|
||||
(and match? (string->number (caddr match?)))))
|
||||
|
||||
;; simplify-module-map: module-path string module-map -> (listof (union number symbol))
|
||||
;; convert the module-map into a simple list
|
||||
(define (simplify-module-map pth labeling-code mod-map)
|
||||
(let loop ([mm mod-map])
|
||||
(cond
|
||||
[(null? mm) '()]
|
||||
[(and (same-module? pth (caar mm))
|
||||
(match-label (cdar mm)))
|
||||
=> (lambda (lab) (cons lab (loop (cdr mm))))]
|
||||
[(same-module? '(lib "abort-resume.ss" "web-server" "prototype-web-server" "private") (caar mm))
|
||||
(cons (cdar mm) (loop (cdr mm)))]
|
||||
[else
|
||||
(error "cannot construct abreviated module map" mod-map)])))
|
||||
|
||||
;; same-module?: module-path module-path -> boolean
|
||||
;; do the module paths specify the same module?
|
||||
(define (same-module? path-str mod-path)
|
||||
(eqv? ((current-module-name-resolver) path-str #f #f)
|
||||
((current-module-name-resolver) mod-path #f #f)))
|
||||
|
||||
;; stuff-url: serial url path -> url
|
||||
;; encode in the url
|
||||
#;(define (stuff-url svl uri pth)
|
||||
(let-values ([(l-code simple-mod-map graph fixups sv)
|
||||
(url-parts pth svl)])
|
||||
(let ([new-query
|
||||
`(,(cons 'c l-code)
|
||||
,@(if (null? graph) '()
|
||||
(list (cons 'g (format "~s" graph))))
|
||||
,@(if (null? fixups) '()
|
||||
(list (cons 'f (format "~s" fixups))))
|
||||
,(cons 'v (format "~s" sv)))])
|
||||
(let ([result-uri
|
||||
(make-url
|
||||
(url-scheme uri)
|
||||
(url-user uri)
|
||||
(url-host uri)
|
||||
(url-port uri)
|
||||
#t
|
||||
(append (url-path uri)
|
||||
(map
|
||||
(lambda (n-or-sym) (make-path/param (format "~a" n-or-sym) empty))
|
||||
simple-mod-map))
|
||||
new-query
|
||||
(url-fragment uri))])
|
||||
(begin0
|
||||
result-uri
|
||||
(when (> (string-length (url->string result-uri))
|
||||
1024)
|
||||
(error "the url is too big: " (url->string result-uri))))))))
|
||||
unstuff-url)
|
||||
|
||||
; XXX Abstract this
|
||||
(require (lib "md5.ss"))
|
||||
|
|
@ -215,23 +26,15 @@
|
|||
(build-path (find-system-path 'home-dir) ".urls" (format "~a" hash))
|
||||
(lambda () (read))))
|
||||
|
||||
;; stuff-url: serial url path -> url
|
||||
;; encode in the url
|
||||
(define (stuff-url svl uri pth)
|
||||
#;(printf "stuff: ~s~n" svl)
|
||||
(let ([result-uri
|
||||
(make-url
|
||||
(url-scheme uri)
|
||||
(url-user uri)
|
||||
(url-host uri)
|
||||
(url-port uri)
|
||||
#t
|
||||
(url-path uri)
|
||||
(list (cons 'c (md5-store (write/string (compress-serial svl)))))
|
||||
(url-fragment uri))])
|
||||
(begin0
|
||||
result-uri
|
||||
(when (> (string-length (url->string result-uri))
|
||||
1024)
|
||||
(error "the url is too big: " (url->string result-uri))))))
|
||||
(define result-uri
|
||||
(extend-url-query uri 'c (md5-store (write/string (compress-serial svl)))))
|
||||
(when (> (string-length (url->string result-uri))
|
||||
1024)
|
||||
(error "the url is too big: " (url->string result-uri)))
|
||||
result-uri)
|
||||
|
||||
(define (extend-url-query uri key val)
|
||||
(make-url
|
||||
|
|
@ -244,32 +47,8 @@
|
|||
(list* (cons key val)
|
||||
(url-query uri))
|
||||
(url-fragment uri)))
|
||||
|
||||
|
||||
;; unstuff-url: url url path -> serial
|
||||
;; decode from the url and reconstruct the serial
|
||||
#;(define (unstuff-url req-url ses-url mod-path)
|
||||
(let ([suff (split-url-path ses-url req-url)]
|
||||
[qry (url-query req-url)])
|
||||
(recover-serial
|
||||
mod-path
|
||||
(find-binding 'c qry)
|
||||
(map
|
||||
(lambda (elt)
|
||||
(define nelt (string->number elt))
|
||||
(if (not nelt) (string->symbol elt)
|
||||
nelt))
|
||||
suff)
|
||||
(or (find-binding 'g qry) '())
|
||||
(or (find-binding 'f qry) '())
|
||||
(find-binding 'v qry))))
|
||||
(define (unstuff-url req-url ses-url mod-path)
|
||||
(decompress-serial (read/string (md5-lookup (find-binding 'c (url-query req-url))))))
|
||||
|
||||
;; find-binding: symbol (list (cons symbol string)) -> (union string #f)
|
||||
;; find the binding in the query or return false
|
||||
(define (find-binding key qry)
|
||||
(cond
|
||||
[(null? qry) #f]
|
||||
[(eqv? key (caar qry))
|
||||
(read (open-input-string (cdar qry)))]
|
||||
[else (find-binding key (cdr qry))])))
|
||||
(decompress-serial (read/string (md5-lookup (find-binding 'c (url-query req-url)))))))
|
||||
|
|
@ -6,12 +6,22 @@
|
|||
(lib "serialize.ss"))
|
||||
|
||||
(provide/contract
|
||||
[find-binding (symbol? (listof (cons/c symbol? string?)) . -> . (or/c serializable? false/c))]
|
||||
[read/string (string? . -> . serializable?)]
|
||||
[write/string (serializable? . -> . string?)]
|
||||
[url->servlet-path (url? . -> . (listof string?))]
|
||||
[url->servlet-path ((path? url?) . ->* . ((or/c path? false/c) (or/c (listof string?) false/c) (or/c (listof string?) false/c)))]
|
||||
[make-session-url (url? (listof string?) . -> . url?)]
|
||||
[split-url-path (url? url? . -> . (or/c (listof string?) false/c))])
|
||||
|
||||
;; find-binding: symbol (list (cons symbol string)) -> (union string #f)
|
||||
;; find the binding in the query or return false
|
||||
(define (find-binding key qry)
|
||||
(cond
|
||||
[(null? qry) #f]
|
||||
[(eqv? key (caar qry))
|
||||
(read/string (cdar qry))]
|
||||
[else (find-binding key (cdr qry))]))
|
||||
|
||||
(define (read/string str)
|
||||
(read (open-input-string str)))
|
||||
(define (write/string v)
|
||||
|
|
@ -109,7 +119,7 @@
|
|||
rest-of-path)]
|
||||
[else (loop new-base
|
||||
(list* next-path-segment servlet-path)
|
||||
rest-of-path)]))])))
|
||||
rest-of-path)]))])))
|
||||
|
||||
;; split-url-path: url url -> (union (listof string) #f)
|
||||
;; the first url's path is a prefix of the path of the second
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@
|
|||
(rename "abort-resume.ss" send/suspend0 send/suspend)
|
||||
(all-except "abort-resume.ss" send/suspend)
|
||||
"session.ss"
|
||||
"stuff-url.ss")
|
||||
"stuff-url.ss"
|
||||
"utils.ss")
|
||||
|
||||
(provide
|
||||
;; Server Interface
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
(module stuff-url-tests mzscheme
|
||||
(require (lib "stuff-url.ss" "web-server" "prototype-web-server" "private")
|
||||
(lib "mod-map.ss" "web-server" "prototype-web-server" "private")
|
||||
(planet "test.ss" ("schematics" "schemeunit.plt" 2))
|
||||
(planet "util.ss" ("schematics" "schemeunit.plt" 2))
|
||||
(lib "url.ss" "net")
|
||||
|
|
@ -8,20 +9,14 @@
|
|||
(lib "etc.ss")
|
||||
"util.ss")
|
||||
|
||||
(require/expose (lib "stuff-url.ss" "web-server" "prototype-web-server" "private")
|
||||
(same-module? url-parts recover-serial))
|
||||
|
||||
(provide stuff-url-suite)
|
||||
|
||||
(define uri0 (string->url "www.google.com"))
|
||||
(define uri0 (string->url "www.google.com"))
|
||||
|
||||
(define (simplify-unsimplify svl pth)
|
||||
(let-values ([(l-code simple-mod-map graph fixups sv)
|
||||
(url-parts pth svl)])
|
||||
(recover-serial
|
||||
pth
|
||||
l-code
|
||||
simple-mod-map graph fixups sv)))
|
||||
(define (simplify-unsimplify v)
|
||||
(decompress-serial
|
||||
(compress-serial
|
||||
v)))
|
||||
|
||||
(define (stuff-unstuff svl uri mod-path)
|
||||
(let ([result-uri (stuff-url svl uri mod-path)])
|
||||
|
|
@ -37,40 +32,20 @@
|
|||
|
||||
(define stuff-url-suite
|
||||
(test-suite
|
||||
"Tests for stuff-url.ss"
|
||||
|
||||
(test-case
|
||||
"Test same-module?"
|
||||
|
||||
(check-true
|
||||
(same-module? `(file ,(path->string (build-absolute-path (find-collects-dir) "web-server" "prototype-web-server" "private" "abort-resume.ss")))
|
||||
'(lib "abort-resume.ss" "web-server" "prototype-web-server" "private")))
|
||||
|
||||
(check-true
|
||||
(same-module? `(file ,(path->string (build-absolute-path (this-expression-source-directory) "../private/abort-resume.ss")))
|
||||
'(lib "abort-resume.ss" "web-server" "prototype-web-server" "private")))
|
||||
|
||||
(check-true
|
||||
(same-module?
|
||||
'(lib "abort-resume.ss" "web-server" "prototype-web-server" "private")
|
||||
'(lib "./abort-resume.ss" "web-server" "prototype-web-server" "private"))))
|
||||
"Tests for stuff-url.ss"
|
||||
|
||||
(test-case
|
||||
"compose url-parts and recover-serial (1)"
|
||||
(let-values ([(ev) (make-eval/mod-path m00)])
|
||||
(let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start start 'foo)))
|
||||
m00)]
|
||||
[k1 (simplify-unsimplify (ev `(serialize (dispatch ,the-dispatch (list (deserialize ',k0) 1))))
|
||||
m00)]
|
||||
[k2 (simplify-unsimplify (ev `(serialize (dispatch ,the-dispatch (list (deserialize ',k1) 2))))
|
||||
m00)])
|
||||
(let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start start 'foo))))]
|
||||
[k1 (simplify-unsimplify (ev `(serialize (dispatch ,the-dispatch (list (deserialize ',k0) 1)))))]
|
||||
[k2 (simplify-unsimplify (ev `(serialize (dispatch ,the-dispatch (list (deserialize ',k1) 2)))))])
|
||||
(check-true (= 6 (ev `(dispatch ,the-dispatch (list (deserialize ',k2) 3))))))))
|
||||
|
||||
(test-case
|
||||
"compose url-parts and recover-serial (2)"
|
||||
(let-values ([(ev) (make-eval/mod-path m01)])
|
||||
(let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start start 'foo)))
|
||||
m01)])
|
||||
(let* ([k0 (simplify-unsimplify (ev '(serialize (dispatch-start start 'foo))))])
|
||||
(check-true (= 7 (ev `(dispatch ,the-dispatch (list (deserialize ',k0) 7))))))))
|
||||
|
||||
(test-case
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user