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

abstracting stuffing

Browse Source 
svn: r13469
This commit is contained in:
Jay McCarthy 2009-02-06 19:58:50 +00:00
parent a1c1a80d2e
commit 4f952a65d2
5 changed files with 184 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/tests/web-server/lang/stuff-url-test.ss
View File

@ -8,9 +8,11 @@
(define uri0 (string->url "www.google.com"))
(define test-stuffer serialize-stuffer)
(define (stuff-unstuff svl uri)
(let ([result-uri (stuff-url svl uri)])
(unstuff-url result-uri)))
(let ([result-uri (stuff-url test-stuffer uri svl)])
(unstuff-url test-stuffer result-uri)))
(define (cidentity v)
(deserialize
(stuff-unstuff (serialize v) uri0)))
@ -37,10 +39,10 @@
(test-suite
"stuffed-url? works"
(test-case "Not stuffed URL" (check-false (stuffed-url? uri0)))
(test-case "Integers" (check-true (stuffed-url? (stuff-url (serialize 3) uri0))))
(test-case "Symbols" (check-true (stuffed-url? (stuff-url (serialize 'foo) uri0))))
(test-case "Strings" (check-true (stuffed-url? (stuff-url (serialize "Bar") uri0))))
(test-case "Vectors" (check-true (stuffed-url? (stuff-url (serialize (vector 3 1 4)) uri0)))))
(test-case "Integers" (check-true (stuffed-url? (stuff-url test-stuffer uri0 (serialize 3)))))
(test-case "Symbols" (check-true (stuffed-url? (stuff-url test-stuffer uri0 (serialize 'foo)))))
(test-case "Strings" (check-true (stuffed-url? (stuff-url test-stuffer uri0 (serialize "Bar")))))
(test-case "Vectors" (check-true (stuffed-url? (stuff-url test-stuffer uri0 (serialize (vector 3 1 4)))))))
(test-case
"Using stuff-url with lang.ss"

179
collects/web-server/lang/stuff-url.ss
View File

@ -3,16 +3,151 @@
scheme/serialize
web-server/private/md5-store
web-server/private/gzip
web-server/private/servlet
web-server/http
"../private/util.ss"
"../private/url-param.ss"
"../private/mod-map.ss")
;; NEW
; A stuffer is
; - in : any -> bytes
; - out : bytes -> any
; such that
; out (in x) = x
; in (out x) = x
(define-struct stuffer (in out))
(define id-stuffer
(make-stuffer
(lambda (v) v)
(lambda (v) v)))
(define serialize-stuffer
(make-stuffer
(lambda (v) (write/bytes (compress-serial (serialize v))))
(lambda (v) (deserialize (decompress-serial (read/bytes v))))))
(define gzip-stuffer
(make-stuffer gzip/bytes gunzip/bytes))
(require net/base64)
(define base64-stuffer
(make-stuffer base64-encode base64-decode))
(define-struct store (write read))
(define (dir-store home)
(make-store
(lambda (key value)
(with-output-to-file
(build-path home (format "~a" key))
(lambda ()
(write value))
#:exists 'replace))
(lambda (key)
(with-input-from-file
(build-path home (format "~a" key))
(lambda () (read))))))
(define (hash-stuffer hash store)
(make-stuffer
(lambda (v)
(define hv (hash v))
((store-write store) hv v)
hv)
(lambda (hv)
((store-read store) hv))))
(require file/md5)
(define (md5-stuffer home)
(hash-stuffer md5 (dir-store home)))
(define (stuffer-compose g f)
(make-stuffer
(lambda (v)
((stuffer-in g) ((stuffer-in f) v)))
(lambda (v)
((stuffer-out f) ((stuffer-out g) v)))))
(define (stuffer-sequence f g)
(stuffer-compose g f))
(define (stuffer-if c f)
(make-stuffer
(lambda (v)
(if (c v)
(bytes-append #"1" ((stuffer-in f) v))
(bytes-append #"0" v)))
(lambda (tv)
(define tag (subbytes tv 0 1))
(define v (subbytes tv 1))
(if (bytes=? tag #"1")
((stuffer-out f) v)
v))))
(define (stuffer-chain . ss)
(match ss
[(list)
id-stuffer]
[(list-rest f ss)
(cond
[(stuffer? f)
(stuffer-sequence
f (apply stuffer-chain ss))]
[(procedure? f)
(stuffer-if
f (apply stuffer-chain ss))])]))
(define (is-url-too-big? v)
(define uri
(request-uri (execution-context-request (current-execution-context))))
(url-too-big?
(do-url-stuff uri v)))
(define default-stuffer
(stuffer-chain
serialize-stuffer
is-url-too-big?
(stuffer-chain
gzip-stuffer
base64-stuffer)
is-url-too-big?
(md5-stuffer (md5-home))))
(define URL-KEY "c")
(define (do-url-stuff uri c)
(insert-param uri URL-KEY (bytes->string/utf-8 c)))
(define (stuff-url stuffer uri c)
(do-url-stuff
uri
((stuffer-in stuffer) c)))
(define (stuffed-url? uri)
(string? (extract-param uri URL-KEY)))
(define (unstuff-url stuffer uri)
((stuffer-out stuffer)
(string->bytes/utf-8
(extract-param uri URL-KEY))))
(provide/contract
[struct stuffer
([in (any/c . -> . bytes?)]
[out (bytes? . -> . any/c)])]
[id-stuffer stuffer?]
[serialize-stuffer stuffer?]
[default-stuffer stuffer?])
;; OLD
(provide/contract
[max-url-length (parameter/c number?)]
[url-too-big? (url? . -> . boolean?)]
[stuff-url (serializable? url? . -> . url?)]
[stuff-url (stuffer? url? serializable? . -> . url?)]
[stuffed-url? (url? . -> . boolean?)]
[unstuff-url (url? . -> . serializable?)])
[unstuff-url (stuffer? url? . -> . serializable?)])
; http://www.boutell.com/newfaq/misc/urllength.html
(define max-url-length
@ -20,43 +155,3 @@
(define (url-too-big? uri)
((string-length (url->string uri)) . > . (max-url-length)))
;; stuff-url: serial url -> url
;; encode in the url
(require net/base64)
(define (stuff-url c uri)
(let* ([cb (c->bytes c)]
[cb-uri (insert-param uri "c" (bytes->string/utf-8 cb))])
(if (url-too-big? cb-uri)
(let* ([cc (gzip/bytes cb)]
[cc-uri (insert-param uri "cc" (bytes->string/utf-8 (base64-encode cc)))])
(if (url-too-big? cc-uri)
(let* ([hc (md5-store cc)]
[hc-uri (insert-param uri "hc" (bytes->string/utf-8 hc))])
(if (url-too-big? hc-uri)
(error 'stuff-url "Continuation too big: ~a" c)
hc-uri))
cc-uri))
cb-uri)))
(define (stuffed-url? uri)
(and (or (extract-param uri "c")
(extract-param uri "cc")
(extract-param uri "hc"))
#t))
(define (c->bytes c)
(write/bytes (compress-serial (serialize c))))
(define (bytes->c b)
(deserialize (decompress-serial (read/bytes b))))
;; unstuff-url: url -> serial
;; decode from the url and reconstruct the serial
(define (unstuff-url uri)
(cond
[(extract-param uri "c")
=> (compose bytes->c string->bytes/utf-8)]
[(extract-param uri "cc")
=> (compose bytes->c gunzip/bytes base64-decode string->bytes/utf-8)]
[(extract-param uri "hc")
=> (compose bytes->c gunzip/bytes md5-lookup string->bytes/utf-8)]))

43
collects/web-server/lang/web.ss
View File

@ -3,31 +3,39 @@
scheme/contract
scheme/serialize
web-server/http
web-server/managers/manager
web-server/private/define-closure
web-server/private/servlet
"abort-resume.ss"
"stuff-url.ss"
"../private/url-param.ss")
(define-struct (stateless-servlet servlet) (stuffer))
(provide
;; Server Interface
initialize-servlet
initialize-servlet
;; Servlet Interface
send/suspend/hidden
send/suspend/url
send/suspend/dispatch)
(provide/contract
[make-stateless-servlet
(custodian? namespace? manager? path-string? (request? . -> . response/c)
stuffer? . -> . stateless-servlet?)])
; These contracts interfere with the continuation safety marks
#;(provide/contract
;; Server Interface
[initialize-servlet ((request? . -> . response/c) . -> . (request? . -> . response/c))]
;; Servlet Interface
[send/suspend/hidden ((url? list? . -> . response/c) . -> . request?)]
[send/suspend/url ((url? . -> . response/c) . -> . request?)]
[send/suspend/dispatch ((((request? . -> . any/c) . -> . url?) . -> . response/c)
. -> . any/c)])
;; Server Interface
[initialize-servlet ((request? . -> . response/c) . -> . (request? . -> . response/c))]
;; Servlet Interface
[send/suspend/hidden ((url? list? . -> . response/c) . -> . request?)]
[send/suspend/url ((url? . -> . response/c) . -> . request?)]
[send/suspend/dispatch ((((request? . -> . any/c) . -> . url?) . -> . response/c)
. -> . any/c)])
;; initial-servlet : (request -> response) -> (request -> response/c)
(define (initialize-servlet start)
@ -59,13 +67,16 @@
(define (send/suspend/url page-maker)
(send/suspend
(lambda (k)
(define stuffer (stateless-servlet-stuffer (current-servlet)))
(page-maker
(stuff-url k
(request-uri (execution-context-request (current-execution-context))))))))
(stuff-url stuffer
(request-uri (execution-context-request (current-execution-context)))
k)))))
(define-closure embed/url (proc) (k)
(stuff-url (kont-append-fun k proc)
(request-uri (execution-context-request (current-execution-context)))))
(stuff-url (stateless-servlet-stuffer (current-servlet))
(request-uri (execution-context-request (current-execution-context)))
(kont-append-fun k proc)))
(define (send/suspend/dispatch response-generator)
(send/suspend
(lambda (k)
@ -76,10 +87,10 @@
(define (request->continuation req)
(or
; Look in url for c=<k>
(let ([req-url (request-uri req)])
(let* ([req-url (request-uri req)]
[stuffer (stateless-servlet-stuffer (current-servlet))])
(and (stuffed-url? req-url)
(unstuff-url
req-url)))
(unstuff-url stuffer req-url)))
; Look in query for kont=<k>
(match (bindings-assq #"kont" (request-bindings/raw req))
[(struct binding:form (id kont))

2
collects/web-server/scribblings/lang.scrbl
View File

@ -62,6 +62,7 @@ See @schememodname[web-server/servlet/web].}
}
@; ------------------------------------------------------------
@;{
@section[#:tag "lang/stuff-url.ss"]{Stuff URL}
@(require (for-label web-server/lang/stuff-url))
@ -104,3 +105,4 @@ In the future, we will offer the facilities to:
@item{Only use the CAS if the URL would be too long. (URLs may only be 1024 characters.)}
]
}
;}

14
collects/web-server/servlet/setup.ss
View File

@ -4,8 +4,10 @@
(require web-server/managers/manager
web-server/managers/timeouts
web-server/managers/none
web-server/lang/stuff-url
(only-in web-server/lang/web
initialize-servlet)
initialize-servlet
make-stateless-servlet)
web-server/http
web-server/servlet/web
web-server/configuration/namespace
@ -67,11 +69,12 @@
(define (make-stateless.servlet directory start)
(define ses
(make-servlet
(make-stateless-servlet
(current-custodian) (current-namespace)
(create-none-manager (lambda (req) (error "No continuations!")))
directory
(lambda (req) (error "Session not initialized"))))
(lambda (req) (error "Session not initialized"))
default-stuffer))
(parameterize ([current-directory directory]
[current-servlet ses])
(set-servlet-handler! ses (initialize-servlet start)))
@ -92,11 +95,14 @@
web-server/servlet/web-cells:module-path))
(define-runtime-module-path web-server/lang/web-cells:module-path web-server/lang/web-cells)
(define-runtime-module-path web-server/lang/web:module-path web-server/lang/web)
(define-runtime-module-path web-server/lang/abort-resume:module-path web-server/lang/abort-resume)
(define lang-module-specs
(list web-server/lang/web-cells:module-path
#;web-server/lang/abort-resume:module-path ; XXX Enabling results in error
'web-server/lang/abort-resume))
'web-server/lang/abort-resume
#;web-server/lang/web:module-path ; XXX Enabling results in error
'web-server/lang/web))
(define default-module-specs
(append common-module-specs
servlet-module-specs