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

Changing bindings parser on requests to promises.

Browse Source 
svn: r18310
This commit is contained in:
Jay McCarthy 2010-02-23 22:29:22 +00:00
parent 08e10674ea
commit 652cdcf902
13 changed files with 63 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/web-server/dispatch-test.ss
View File

@ -14,7 +14,7 @@
(provide all-dispatch-tests)
(define (test-request url)
(make-request #"GET" url null null #f "1.2.3.4" 123 "4.3.2.1"))
(make-request #"GET" url null (delay null) #f "1.2.3.4" 123 "4.3.2.1"))
(define all-dispatch-tests
(test-suite

2
collects/tests/web-server/dispatchers/dispatch-files-test.ss
View File

@ -38,7 +38,7 @@
(define file-url (string->url "http://test.com/foo"))
(define dir-url (string->url "http://test.com/foo/"))
(define (req d? meth heads)
(make-request meth (if d? dir-url file-url) heads empty #"" "host" 80 "client"))
(make-request meth (if d? dir-url file-url) heads (delay empty) #"" "host" 80 "client"))
(define dispatch-files-tests
(test-suite

7
collects/tests/web-server/dispatchers/dispatch-passwords-test.ss
View File

@ -3,8 +3,9 @@
(only-in mzlib/file
make-temporary-file)
net/url
mzlib/list
mzlib/serialize
scheme/promise
scheme/list
scheme/serialize
web-server/http
web-server/dispatchers/dispatch
(prefix-in passwords: web-server/dispatchers/dispatch-passwords)
@ -48,7 +49,7 @@
(if authorized?
(list (make-header #"Authorization" #"Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ=="))
empty)
empty #"" "host" 80 "client"))))
(delay empty) #"" "host" 80 "client"))))
(define dispatch-passwords-tests
(test-suite

15
collects/tests/web-server/formlets-test.ss
View File

@ -126,7 +126,7 @@
(formlet-process f
(make-request #"GET" (string->url "http://test.com")
empty
bs
(delay bs)
#f "127.0.0.1" 80 "127.0.0.1")))]
(test-suite
"Input"
@ -161,7 +161,7 @@
(test-equal? "default"
(test-process (default #"def" (text-input)) empty)
#"def")
(test-equal? "to-string"
(test-process (to-string (required (text-input))) (list (make-binding:form #"input_0" #"value")))
"value")
@ -244,11 +244,12 @@
(check-equal? (formlet-process travel-formlet
(make-request #"GET" (string->url "http://test.com")
empty
(list (make-binding:form #"input_0" #"Jay")
(make-binding:form #"input_1" #"10")
(make-binding:form #"input_2" #"6")
(make-binding:form #"input_3" #"10")
(make-binding:form #"input_4" #"8"))
(delay
(list (make-binding:form #"input_0" #"Jay")
(make-binding:form #"input_1" #"10")
(make-binding:form #"input_2" #"6")
(make-binding:form #"input_3" #"10")
(make-binding:form #"input_4" #"8")))
#f "127.0.0.1" 80 "127.0.0.1"))
(list "Jay" (make-date 10 6) (make-date 10 8))))))

14
collects/tests/web-server/http/cookies-test.ss
View File

@ -75,7 +75,7 @@
(request-cookies
(make-request
#"GET" (string->url "http://test.com/foo")
empty empty #f
empty (delay empty) #f
"host" 80 "client"))
empty)
@ -84,7 +84,7 @@
(make-request
#"GET" (string->url "http://test.com/foo")
(list (make-header #"Cookie" #"$Version=\"1\"; name=\"value\""))
empty #f
(delay empty) #f
"host" 80 "client"))
(list (make-client-cookie "name" "value" #f #f)))
@ -93,7 +93,7 @@
(make-request
#"GET" (string->url "http://test.com/foo")
(list (make-header #"Cookie" #"$Version=\"1\"; name=\"value\"; $Path=\"/acme\""))
empty #f
(delay empty) #f
"host" 80 "client"))
(list (make-client-cookie "name" "value" #f "/acme")))
@ -102,7 +102,7 @@
(make-request
#"GET" (string->url "http://test.com/foo")
(list (make-header #"Cookie" #"$Version=\"1\"; name=\"value\"; $Domain=\".acme\""))
empty #f
(delay empty) #f
"host" 80 "client"))
(list (make-client-cookie "name" "value" ".acme" #f)))
@ -111,7 +111,7 @@
(make-request
#"GET" (string->url "http://test.com/foo")
(list (make-header #"Cookie" #"$Version=\"1\"; key1=\"value1\"; key2=\"value2\""))
empty #f
(delay empty) #f
"host" 80 "client"))
(list (make-client-cookie "key1" "value1" #f #f)
(make-client-cookie "key2" "value2" #f #f)))
@ -121,7 +121,7 @@
(make-request
#"GET" (string->url "http://test.com/foo")
(list (make-header #"Cookie" #"$Version=\"1\"; key1=\"value1\"; $Path=\"/acme\"; key2=\"value2\"; $Domain=\".acme\""))
empty #f
(delay empty) #f
"host" 80 "client"))
(list (make-client-cookie "key1" "value1" #f "/acme")
(make-client-cookie "key2" "value2" ".acme" #f)))
@ -132,7 +132,7 @@
#"GET" (string->url "http://test.com/foo")
(list (make-header #"Cookie"
#"style_cookie=null; phpbb3_e1p9b_u=54; phpbb3_e1p9b_k=; phpbb3_e1p9b_sid=3fa8d7a7b65fbabcbe9b345861dc079a"))
empty #f
(delay empty) #f
"host" 80 "client"))
(list (make-client-cookie "style_cookie" "null" #f #f)
(make-client-cookie "phpbb3_e1p9b_u" "54" #f #f)

2
collects/tests/web-server/http/digest-auth-test.ss
View File

@ -44,7 +44,7 @@ END
(make-request
#"GET" (string->url "http://test.com/foo")
hs
empty #f
(delay empty) #f
"host" 80 "client"))
(define (header->cons h)

2
collects/tests/web-server/servlet/basic-auth-test.ss
View File

@ -8,7 +8,7 @@
(make-request
#"GET" (string->url "http://test.com/foo")
hs
empty #f
(delay empty) #f
"host" 80 "client"))
(define (header->cons h)

15
collects/tests/web-server/servlet/bindings-test.ss
View File

@ -18,22 +18,23 @@
"Simple"
(check-equal? (request-bindings
(make-request #"GET" (string->url "http://test.com/foo")
empty (list (make-binding:form #"key" #"val")) #f
empty (delay (list (make-binding:form #"key" #"val"))) #f
"host" 80 "client"))
'((key . "val"))))
(test-case
"Case"
(check-equal? (request-bindings
(make-request #"GET" (string->url "http://test.com/foo")
empty (list (make-binding:form #"KEY" #"val")) #f
empty (delay (list (make-binding:form #"KEY" #"val"))) #f
"host" 80 "client"))
'((key . "val"))))
(test-case
"Multi"
(check-equal? (request-bindings
(make-request #"GET" (string->url "http://test.com/foo")
empty (list (make-binding:form #"key" #"val")
(make-binding:form #"key2" #"val")) #f
empty (delay (list (make-binding:form #"key" #"val")
(make-binding:form #"key2" #"val")))
#f
"host" 80 "client"))
'((key . "val")
(key2 . "val"))))
@ -41,7 +42,7 @@
"File"
(check-equal? (request-bindings
(make-request #"GET" (string->url "http://test.com/foo")
empty (list (make-binding:file #"key" #"file" empty #"val")) #f
empty (delay (list (make-binding:file #"key" #"file" empty #"val"))) #f
"host" 80 "client"))
'((key . #"val")))))
@ -51,14 +52,14 @@
"Simple"
(check-equal? (request-headers
(make-request #"GET" (string->url "http://test.com/foo")
(list (make-header #"key" #"val")) empty #f
(list (make-header #"key" #"val")) (delay empty) #f
"host" 80 "client"))
'((key . "val"))))
(test-case
"Case"
(check-equal? (request-headers
(make-request #"GET" (string->url "http://test.com/foo")
(list (make-header #"KEY" #"val")) empty #f
(list (make-header #"KEY" #"val")) (delay empty) #f
"host" 80 "client"))
'((key . "val")))))

2
collects/tests/web-server/stuffers-test.ss
View File

@ -28,7 +28,7 @@
(parameterize ([current-execution-context
(make-execution-context
(make-request #"GET" (string->url "http://www.google.com")
empty empty
empty (delay empty)
#"" "127.0.0.1" 80
"127.0.0.1"))])
(thnk)))

2
collects/tests/web-server/util.ss
View File

@ -18,7 +18,7 @@
call)
(define (call d u bs)
(htxml (collect d (make-request #"GET" (string->url u) empty bs #"" "127.0.0.1" 80 "127.0.0.1"))))
(htxml (collect d (make-request #"GET" (string->url u) empty (delay bs) #"" "127.0.0.1" 80 "127.0.0.1"))))
(define (htxml bs)
(match (regexp-match #"^.+\r\n\r\n(.+)$" bs)
[(list _ s)

15
collects/web-server/http/request-structs.ss
View File

@ -1,7 +1,8 @@
#lang scheme/base
(require mzlib/contract
mzlib/serialize
mzlib/plt-match
(require scheme/contract
scheme/serialize
scheme/match
scheme/promise
net/url
web-server/private/util)
@ -49,12 +50,16 @@
[headers (listof header?)]
[content bytes?])])
(define-serializable-struct request (method uri headers/raw bindings/raw post-data/raw host-ip host-port client-ip))
(define-serializable-struct request (method uri headers/raw bindings/raw-promise post-data/raw host-ip host-port client-ip))
(define (request-bindings/raw r)
(force (request-bindings/raw-promise r)))
(provide/contract
[request-bindings/raw (request? . -> . (listof binding?))]
[struct request ([method bytes?]
[uri url?]
[headers/raw (listof header?)]
[bindings/raw (listof binding?)]
[bindings/raw-promise (promise/c (listof binding?))]
[post-data/raw (or/c false/c bytes?)]
[host-ip string?] [host-port number?]
[client-ip string?])])

28
collects/web-server/http/request.ss
View File

@ -1,7 +1,5 @@
#lang scheme
(require mzlib/plt-match
net/url
mzlib/list
(require net/url
net/uri-codec
web-server/private/util
web-server/private/connection-manager
@ -41,10 +39,10 @@
(void)]))
(define-values (host-ip client-ip)
(port-addresses ip))
(define-values (bindings raw-post-data)
(define-values (bindings/raw-promise raw-post-data)
(read-bindings&post-data/raw conn method uri headers))
(values
(make-request method uri headers bindings raw-post-data
(make-request method uri headers bindings/raw-promise raw-post-data
host-ip host-port client-ip)
(close-connection? headers major minor
client-ip host-ip)))
@ -152,14 +150,15 @@
(define (read-bindings&post-data/raw conn meth uri headers)
(cond
[(bytes-ci=? #"GET" meth)
(values (filter (lambda (x) x)
(values (delay
(filter (lambda (x) x)
(map (match-lambda
[(list-rest k v)
(if (and (symbol? k) (string? v))
(make-binding:form (string->bytes/utf-8 (symbol->string k))
(string->bytes/utf-8 v))
#f)])
(url-query uri)))
(url-query uri))))
#f)]
[(bytes-ci=? #"POST" meth)
(local
@ -170,7 +169,8 @@
=> (match-lambda
[(list _ content-boundary)
(values
(map (match-lambda
(delay
(map (match-lambda
[(struct mime-part (headers contents))
(define rhs (header-value (headers-assq* #"Content-Disposition" headers)))
(match (list (regexp-match #"filename=(\"([^\"]*)\"|([^ ;]*))" rhs)
@ -181,7 +181,7 @@
(make-binding:form (or f0 f1) (apply bytes-append contents))]
[(list (list _ _ f00 f01) (list _ _ f10 f11))
(make-binding:file (or f10 f11) (or f00 f01) headers (apply bytes-append contents))])])
(read-mime-multipart content-boundary in))
(read-mime-multipart content-boundary in)))
#f)])]
[else
(match (headers-assq* #"Content-Length" headers)
@ -190,12 +190,12 @@
[(string->number (bytes->string/utf-8 value))
=> (lambda (len)
(let ([raw-bytes (read-bytes len in)])
(values (parse-bindings raw-bytes) raw-bytes)))]
(values (delay (parse-bindings raw-bytes)) raw-bytes)))]
[else
(network-error 'read-bindings "Post request contained a non-numeric content-length")])]
[#f
(let ([raw-bytes (apply bytes-append (read-to-eof in))])
(values (parse-bindings raw-bytes) raw-bytes))])]))]
(values (delay (parse-bindings raw-bytes)) raw-bytes))])]))]
[(bytes-ci=? #"PUT" meth)
(local
[(define content-type (headers-assq* #"Content-Type" headers))
@ -205,14 +205,14 @@
(cond [(string->number (bytes->string/utf-8 value))
=> (lambda (len)
(let ([raw-bytes (read-bytes len in)])
(values empty raw-bytes)))]
(values (delay empty) raw-bytes)))]
[else
(network-error 'read-bindings "Put request contained a non-numeric content-length")])]
[#f
(let ([raw-bytes (apply bytes-append (read-to-eof in))])
(values empty raw-bytes))]))]
(values (delay empty) raw-bytes))]))]
[meth
(values empty #f)]))
(values (delay empty) #f)]))
;; parse-bindings : bytes? -> (listof binding?)
(define (parse-bindings raw)

7
collects/web-server/scribblings/http.scrbl
View File

@ -56,7 +56,7 @@ The @web-server implements many HTTP RFCs that are provided by this module.
@defstruct[request ([method bytes?]
[uri url?]
[headers/raw (listof header?)]
[bindings/raw (listof binding?)]
[bindings/raw-promise (promise/c (listof binding?))]
[post-data/raw (or/c false/c bytes?)]
[host-ip string?]
[host-port number?]
@ -69,6 +69,11 @@ The @web-server implements many HTTP RFCs that are provided by this module.
You are @bold{unlikely to need to construct} a request struct.
}
@defproc[(request-bindings/raw [r request?])
(listof binding?)]{
Forces @scheme[(request-bindings/raw-promise r)].
}
Here is an example typical of what you will find in many applications:
@schemeblock[
(define (get-number req)