From d74f7c6aae1cf84d5c22ae6c4c4d0018471fe973 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 11 Nov 2006 05:56:22 +0000 Subject: [PATCH] dyoo svn: r4824 --- collects/web-server/private/request.ss | 89 ++++++++++++++------------ collects/web-server/request-structs.ss | 3 +- 2 files changed, 49 insertions(+), 43 deletions(-) diff --git a/collects/web-server/private/request.ss b/collects/web-server/private/request.ss index 12d3b101fc..aeee1aa9ad 100644 --- a/collects/web-server/private/request.ss +++ b/collects/web-server/private/request.ss @@ -27,10 +27,10 @@ (read-headers ip)) (define-values (host-ip client-ip) (port-addresses ip)) - (define bindings - (read-bindings conn method uri headers)) + (define-values (bindings raw-post-data) + (read-bindings&post-data/raw conn method uri headers)) (values - (make-request method uri headers bindings + (make-request method uri headers bindings raw-post-data host-ip host-port client-ip) (close-connection? headers major minor client-ip host-ip))))) @@ -134,47 +134,52 @@ (define FILE-FORM-REGEXP (byte-regexp #"multipart/form-data; *boundary=(.*)")) - ;; read-bindings: connection symbol url (listof header?) -> (or/c (listof binding?) string?) - (define (read-bindings conn meth uri headers) + ;; 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) (match meth ['get - (map (match-lambda - [(list-rest k v) - (make-binding:form (string->bytes/utf-8 (symbol->string k)) - (string->bytes/utf-8 v))]) - (url-query uri))] + (values (map (match-lambda + [(list-rest k v) + (make-binding:form (string->bytes/utf-8 (symbol->string k)) + (string->bytes/utf-8 v))]) + (url-query uri)) + #f)] ['post - (define content-type (headers-assq* #"Content-Type" headers)) - (define in (connection-i-port conn)) - (cond - [(and content-type (regexp-match FILE-FORM-REGEXP (header-value content-type))) - => (match-lambda - [(list _ content-boundary) - (map (match-lambda - [(struct mime-part (headers contents)) - (define rhs (header-value (headers-assq* #"Content-Disposition" headers))) - (match (list (regexp-match #"filename=(\"([^\"]*)\"|([^ ;]*))" rhs) - (regexp-match #"[^e]name=(\"([^\"]*)\"|([^ ;]*))" rhs)) - [(list #f #f) - (network-error 'reading-bindings "Couldn't extract form field name for file upload")] - [(list #f (list _ _ f0 f1)) - (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) (apply bytes-append contents))])]) - (read-mime-multipart content-boundary in))])] - [else - (match (headers-assq* #"Content-Length" headers) - [(struct header (_ value)) - (cond - [(string->number (bytes->string/utf-8 value)) - => (lambda (len) - (parse-bindings (read-bytes len in)))] - [else - (network-error 'read-bindings "Post request contained a non-numeric content-length")])] - [#f - (parse-bindings (apply bytes-append (read-to-eof in)))])])] + (define content-type (headers-assq #"Content-Type" headers)) + (define in (connection-i-port conn)) + (cond + [(and content-type (regexp-match FILE-FORM-REGEXP (header-value content-type))) + => (match-lambda + [(list _ content-boundary) + (values + (map (match-lambda + [(struct mime-part (headers contents)) + (define rhs (header-value (headers-assq #"Content-Disposition" headers))) + (match (list (regexp-match #"filename=(\"([^\"]*)\"|([^ ;]*))" rhs) + (regexp-match #"[^e]name=(\"([^\"]*)\"|([^ ;]*))" rhs)) + [(list #f #f) + (network-error 'reading-bindings "Couldn't extract form field name for file upload")] + [(list #f (list _ _ f0 f1)) + (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) (apply bytes-append contents))])]) + (read-mime-multipart content-boundary in)) + #f)])] + [else + (match (headers-assq #"Content-Length" headers) + [(struct header (_ value)) + (cond + [(string->number (bytes->string/utf-8 value)) + => (lambda (len) + (let ([raw-bytes (read-bytes len in)]) + (values (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))]) + (parse-bindings raw-bytes))])])] [meth - empty])) + (values empty #f)])) ;; parse-bindings : bytes? -> (listof binding?) (define (parse-bindings raw) @@ -195,10 +200,10 @@ (form-urlencoded-decode (bytes->string/utf-8 (subbytes raw (add1 key-end) amp-end))))) - (loop (add1 amp-end))) + (loop (add1 amp-end))) (find-amp (add1 amp-end)))) (find= (add1 key-end))))))) - + ;; ************************************************** ;; read-mime-multipart diff --git a/collects/web-server/request-structs.ss b/collects/web-server/request-structs.ss index 2e5054b83a..cc8fa4b8de 100644 --- a/collects/web-server/request-structs.ss +++ b/collects/web-server/request-structs.ss @@ -50,11 +50,12 @@ [filename bytes?] [content bytes?])]) - (define-struct request (method uri headers/raw bindings/raw + (define-struct request (method uri headers/raw bindings/raw post-data/raw host-ip host-port client-ip)) (provide/contract [struct request ([method symbol?] [uri url?] [headers/raw (listof header?)] [bindings/raw (listof binding?)] + [post-data/raw (or/c false/c bytes?)] [host-ip string?] [host-port number?] [client-ip string?])])) \ No newline at end of file