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) (provide all-dispatch-tests)
(define (test-request url) (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 (define all-dispatch-tests
(test-suite (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 file-url (string->url "http://test.com/foo"))
(define dir-url (string->url "http://test.com/foo/")) (define dir-url (string->url "http://test.com/foo/"))
(define (req d? meth heads) (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 (define dispatch-files-tests
(test-suite (test-suite

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

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

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

@ -126,7 +126,7 @@
(formlet-process f (formlet-process f
(make-request #"GET" (string->url "http://test.com") (make-request #"GET" (string->url "http://test.com")
empty empty
bs (delay bs)
#f "127.0.0.1" 80 "127.0.0.1")))] #f "127.0.0.1" 80 "127.0.0.1")))]
(test-suite (test-suite
"Input" "Input"
@ -244,11 +244,12 @@
(check-equal? (formlet-process travel-formlet (check-equal? (formlet-process travel-formlet
(make-request #"GET" (string->url "http://test.com") (make-request #"GET" (string->url "http://test.com")
empty empty
(delay
(list (make-binding:form #"input_0" #"Jay") (list (make-binding:form #"input_0" #"Jay")
(make-binding:form #"input_1" #"10") (make-binding:form #"input_1" #"10")
(make-binding:form #"input_2" #"6") (make-binding:form #"input_2" #"6")
(make-binding:form #"input_3" #"10") (make-binding:form #"input_3" #"10")
(make-binding:form #"input_4" #"8")) (make-binding:form #"input_4" #"8")))
#f "127.0.0.1" 80 "127.0.0.1")) #f "127.0.0.1" 80 "127.0.0.1"))
(list "Jay" (make-date 10 6) (make-date 10 8)))))) (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 (request-cookies
(make-request (make-request
#"GET" (string->url "http://test.com/foo") #"GET" (string->url "http://test.com/foo")
empty empty #f empty (delay empty) #f
"host" 80 "client")) "host" 80 "client"))
empty) empty)
@ -84,7 +84,7 @@
(make-request (make-request
#"GET" (string->url "http://test.com/foo") #"GET" (string->url "http://test.com/foo")
(list (make-header #"Cookie" #"$Version=\"1\"; name=\"value\"")) (list (make-header #"Cookie" #"$Version=\"1\"; name=\"value\""))
empty #f (delay empty) #f
"host" 80 "client")) "host" 80 "client"))
(list (make-client-cookie "name" "value" #f #f))) (list (make-client-cookie "name" "value" #f #f)))
@ -93,7 +93,7 @@
(make-request (make-request
#"GET" (string->url "http://test.com/foo") #"GET" (string->url "http://test.com/foo")
(list (make-header #"Cookie" #"$Version=\"1\"; name=\"value\"; $Path=\"/acme\"")) (list (make-header #"Cookie" #"$Version=\"1\"; name=\"value\"; $Path=\"/acme\""))
empty #f (delay empty) #f
"host" 80 "client")) "host" 80 "client"))
(list (make-client-cookie "name" "value" #f "/acme"))) (list (make-client-cookie "name" "value" #f "/acme")))
@ -102,7 +102,7 @@
(make-request (make-request
#"GET" (string->url "http://test.com/foo") #"GET" (string->url "http://test.com/foo")
(list (make-header #"Cookie" #"$Version=\"1\"; name=\"value\"; $Domain=\".acme\"")) (list (make-header #"Cookie" #"$Version=\"1\"; name=\"value\"; $Domain=\".acme\""))
empty #f (delay empty) #f
"host" 80 "client")) "host" 80 "client"))
(list (make-client-cookie "name" "value" ".acme" #f))) (list (make-client-cookie "name" "value" ".acme" #f)))
@ -111,7 +111,7 @@
(make-request (make-request
#"GET" (string->url "http://test.com/foo") #"GET" (string->url "http://test.com/foo")
(list (make-header #"Cookie" #"$Version=\"1\"; key1=\"value1\"; key2=\"value2\"")) (list (make-header #"Cookie" #"$Version=\"1\"; key1=\"value1\"; key2=\"value2\""))
empty #f (delay empty) #f
"host" 80 "client")) "host" 80 "client"))
(list (make-client-cookie "key1" "value1" #f #f) (list (make-client-cookie "key1" "value1" #f #f)
(make-client-cookie "key2" "value2" #f #f))) (make-client-cookie "key2" "value2" #f #f)))
@ -121,7 +121,7 @@
(make-request (make-request
#"GET" (string->url "http://test.com/foo") #"GET" (string->url "http://test.com/foo")
(list (make-header #"Cookie" #"$Version=\"1\"; key1=\"value1\"; $Path=\"/acme\"; key2=\"value2\"; $Domain=\".acme\"")) (list (make-header #"Cookie" #"$Version=\"1\"; key1=\"value1\"; $Path=\"/acme\"; key2=\"value2\"; $Domain=\".acme\""))
empty #f (delay empty) #f
"host" 80 "client")) "host" 80 "client"))
(list (make-client-cookie "key1" "value1" #f "/acme") (list (make-client-cookie "key1" "value1" #f "/acme")
(make-client-cookie "key2" "value2" ".acme" #f))) (make-client-cookie "key2" "value2" ".acme" #f)))
@ -132,7 +132,7 @@
#"GET" (string->url "http://test.com/foo") #"GET" (string->url "http://test.com/foo")
(list (make-header #"Cookie" (list (make-header #"Cookie"
#"style_cookie=null; phpbb3_e1p9b_u=54; phpbb3_e1p9b_k=; phpbb3_e1p9b_sid=3fa8d7a7b65fbabcbe9b345861dc079a")) #"style_cookie=null; phpbb3_e1p9b_u=54; phpbb3_e1p9b_k=; phpbb3_e1p9b_sid=3fa8d7a7b65fbabcbe9b345861dc079a"))
empty #f (delay empty) #f
"host" 80 "client")) "host" 80 "client"))
(list (make-client-cookie "style_cookie" "null" #f #f) (list (make-client-cookie "style_cookie" "null" #f #f)
(make-client-cookie "phpbb3_e1p9b_u" "54" #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 (make-request
#"GET" (string->url "http://test.com/foo") #"GET" (string->url "http://test.com/foo")
hs hs
empty #f (delay empty) #f
"host" 80 "client")) "host" 80 "client"))
(define (header->cons h) (define (header->cons h)

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

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

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

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

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

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

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

@ -18,7 +18,7 @@
call) call)
(define (call d u bs) (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) (define (htxml bs)
(match (regexp-match #"^.+\r\n\r\n(.+)$" bs) (match (regexp-match #"^.+\r\n\r\n(.+)$" bs)
[(list _ s) [(list _ s)

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

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

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

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