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

bug

Browse Source 
svn: r13378
This commit is contained in:
Jay McCarthy 2009-02-03 16:39:18 +00:00
parent 7f13cb3da8
commit dce1ab92b5
1 changed files with 38 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,4 +1,4 @@
#lang scheme/base #lang scheme
(require mzlib/contract (require mzlib/contract
mzlib/plt-match mzlib/plt-match
net/url net/url
@ -147,48 +147,49 @@
;; read-bindings&post-data/raw: connection symbol url (listof header?) -> (values (or/c (listof binding?) string?) (or/c bytes? false/c?)) ;; read-bindings&post-data/raw: connection symbol url (listof header?) -> (values (or/c (listof binding?) string?) (or/c bytes? false/c?))
(define (read-bindings&post-data/raw conn meth uri headers) (define (read-bindings&post-data/raw conn meth uri headers)
(match meth (cond
['get [(bytes-ci=? #"GET" meth)
(values (map (match-lambda (values (map (match-lambda
[(list-rest k v) [(list-rest k 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))])
(url-query uri)) (url-query uri))
#f)] #f)]
['post [(bytes-ci=? #"POST" meth)
(define content-type (headers-assq* #"Content-Type" headers)) (local
(define in (connection-i-port conn)) [(define content-type (headers-assq* #"Content-Type" headers))
(cond (define in (connection-i-port conn))]
[(and content-type (regexp-match FILE-FORM-REGEXP (header-value content-type))) (cond
=> (match-lambda [(and content-type (regexp-match FILE-FORM-REGEXP (header-value content-type)))
[(list _ content-boundary) => (match-lambda
(values [(list _ content-boundary)
(map (match-lambda (values
[(struct mime-part (headers contents)) (map (match-lambda
(define rhs (header-value (headers-assq* #"Content-Disposition" headers))) [(struct mime-part (headers contents))
(match (list (regexp-match #"filename=(\"([^\"]*)\"|([^ ;]*))" rhs) (define rhs (header-value (headers-assq* #"Content-Disposition" headers)))
(regexp-match #"[^e]name=(\"([^\"]*)\"|([^ ;]*))" rhs)) (match (list (regexp-match #"filename=(\"([^\"]*)\"|([^ ;]*))" rhs)
[(list #f #f) (regexp-match #"[^e]name=(\"([^\"]*)\"|([^ ;]*))" rhs))
(network-error 'reading-bindings "Couldn't extract form field name for file upload")] [(list #f #f)
[(list #f (list _ _ f0 f1)) (network-error 'reading-bindings "Couldn't extract form field name for file upload")]
(make-binding:form (or f0 f1) (apply bytes-append contents))] [(list #f (list _ _ f0 f1))
[(list (list _ _ f00 f01) (list _ _ f10 f11)) (make-binding:form (or f0 f1) (apply bytes-append contents))]
(make-binding:file (or f10 f11) (or f00 f01) headers (apply bytes-append contents))])]) [(list (list _ _ f00 f01) (list _ _ f10 f11))
(read-mime-multipart content-boundary in)) (make-binding:file (or f10 f11) (or f00 f01) headers (apply bytes-append contents))])])
#f)])] (read-mime-multipart content-boundary in))
[else #f)])]
(match (headers-assq* #"Content-Length" headers) [else
[(struct header (_ value)) (match (headers-assq* #"Content-Length" headers)
(cond [(struct header (_ value))
[(string->number (bytes->string/utf-8 value)) (cond
=> (lambda (len) [(string->number (bytes->string/utf-8 value))
(let ([raw-bytes (read-bytes len in)]) => (lambda (len)
(values (parse-bindings raw-bytes) raw-bytes)))] (let ([raw-bytes (read-bytes len in)])
[else (values (parse-bindings raw-bytes) raw-bytes)))]
(network-error 'read-bindings "Post request contained a non-numeric content-length")])] [else
[#f (network-error 'read-bindings "Post request contained a non-numeric content-length")])]
(let ([raw-bytes (apply bytes-append (read-to-eof in))]) [#f
(values (parse-bindings raw-bytes) raw-bytes))])])] (let ([raw-bytes (apply bytes-append (read-to-eof in))])
(values (parse-bindings raw-bytes) raw-bytes))])]))]
[meth [meth
(values empty #f)])) (values empty #f)]))