From f64d8a52802e4c4825e65c127de53dbfe2c19186 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 13 Nov 2008 21:25:13 +0000 Subject: [PATCH] Exposing MIME headers to user svn: r12431 --- .../tests/web-server/private/request-test.ss | 4 +-- .../tests/web-server/servlet/bindings-test.ss | 4 +-- .../htdocs/servlets/examples/fupload.ss | 34 +++++++++++++++++++ collects/web-server/http/bindings.ss | 2 +- collects/web-server/http/request-structs.ss | 3 +- collects/web-server/http/request.ss | 2 +- collects/web-server/scribblings/http.scrbl | 5 ++- 7 files changed, 46 insertions(+), 8 deletions(-) create mode 100644 collects/web-server/default-web-root/htdocs/servlets/examples/fupload.ss diff --git a/collects/tests/web-server/private/request-test.ss b/collects/tests/web-server/private/request-test.ss index 1b23697b30..d348ceeccb 100644 --- a/collects/tests/web-server/private/request-test.ss +++ b/collects/tests/web-server/private/request-test.ss @@ -1,4 +1,4 @@ -#lang scheme/base +#lang scheme (require (planet "util.ss" ("schematics" "schemeunit.plt" 2)) (planet "test.ss" ("schematics" "schemeunit.plt" 2)) web-server/private/connection-manager @@ -49,7 +49,7 @@ (test-suite "Bindings" (test-equal? "Simple" (binding:form-value (bindings-assq #"key" (list (make-binding:form #"key" #"val")))) #"val") - (test-equal? "Simple (File)" (binding:file-content (bindings-assq #"key" (list (make-binding:file #"key" #"name" #"val")))) #"val") + (test-equal? "Simple (File)" (binding:file-content (bindings-assq #"key" (list (make-binding:file #"key" #"name" empty #"val")))) #"val") (test-false "Not present" (bindings-assq #"key" (list)))) ; XXX This needs to be really extensive, see what Apache has diff --git a/collects/tests/web-server/servlet/bindings-test.ss b/collects/tests/web-server/servlet/bindings-test.ss index 385ea31b47..d3a35ac35d 100644 --- a/collects/tests/web-server/servlet/bindings-test.ss +++ b/collects/tests/web-server/servlet/bindings-test.ss @@ -1,4 +1,4 @@ -#lang scheme/base +#lang scheme (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) mzlib/list net/url @@ -41,7 +41,7 @@ "File" (check-equal? (request-bindings (make-request 'get (string->url "http://test.com/foo") - empty (list (make-binding:file #"key" #"file" #"val")) #f + empty (list (make-binding:file #"key" #"file" empty #"val")) #f "host" 80 "client")) '((key . #"val"))))) diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/fupload.ss b/collects/web-server/default-web-root/htdocs/servlets/examples/fupload.ss new file mode 100644 index 0000000000..470c3747a7 --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/servlets/examples/fupload.ss @@ -0,0 +1,34 @@ +#lang scheme +(require web-server/servlet) +(provide (all-defined-out)) +(define interface-version 'v1) +(define timeout +inf.0) + +(define (start initial-request) + (define req + (send/suspend + (lambda (k-url) + `(html (body (form ([action ,k-url] + [method "post"] + [enctype "multipart/form-data"]) + (input ([type "file"] + [name "somename"])) + (input ([type "submit"])))))))) + (define (header->xexpr h) + (match h + [(struct header (field value)) + `(li (ul (li "Field: " ,(bytes->string/utf-8 field)) + (li "Value: " ,(bytes->string/utf-8 value))))])) + (define (binding->xexpr b) + (match b + [(struct binding:form (field value)) + `(li (ul (li "Field: " ,(bytes->string/utf-8 field)) + (li "Value: " ,(bytes->string/utf-8 value))))] + [(struct binding:file (field filename headers content)) + `(li (ul (li "Field: " ,(bytes->string/utf-8 field)) + (li "Name: " ,(bytes->string/utf-8 filename)) + (li "Headers: " (ul ,@(map header->xexpr headers))) + (li "Contents: " (pre ,(bytes->string/utf-8 content)))))])) + `(html (body ([bgcolor "white"]) + (p "Uploaded:" + (ul ,@(map binding->xexpr (request-bindings/raw req))))))) diff --git a/collects/web-server/http/bindings.ss b/collects/web-server/http/bindings.ss index 1f40f1bc59..7dd8180b57 100644 --- a/collects/web-server/http/bindings.ss +++ b/collects/web-server/http/bindings.ss @@ -16,7 +16,7 @@ [(struct binding:form (id value)) (cons (lowercase-symbol! (bytes->string/utf-8 id)) (bytes->string/utf-8 value))] - [(struct binding:file (id fname value)) + [(struct binding:file (id fname headers value)) (cons (lowercase-symbol! (bytes->string/utf-8 id)) value)]) (request-bindings/raw request))) diff --git a/collects/web-server/http/request-structs.ss b/collects/web-server/http/request-structs.ss index 38099af9c1..d00e3f44c6 100644 --- a/collects/web-server/http/request-structs.ss +++ b/collects/web-server/http/request-structs.ss @@ -33,7 +33,7 @@ (define-serializable-struct binding (id)) (define-serializable-struct (binding:form binding) (value)) -(define-serializable-struct (binding:file binding) (filename content)) +(define-serializable-struct (binding:file binding) (filename headers content)) (define (bindings-assq ti bs) (match bs [(list) @@ -49,6 +49,7 @@ [value bytes?])] [struct (binding:file binding) ([id bytes?] [filename bytes?] + [headers (listof header?)] [content bytes?])]) (define-serializable-struct request (method uri headers/raw bindings/raw post-data/raw diff --git a/collects/web-server/http/request.ss b/collects/web-server/http/request.ss index e3f800d54f..bbfae455fd 100644 --- a/collects/web-server/http/request.ss +++ b/collects/web-server/http/request.ss @@ -173,7 +173,7 @@ [(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))])]) + (make-binding:file (or f10 f11) (or f00 f01) headers (apply bytes-append contents))])]) (read-mime-multipart content-boundary in)) #f)])] [else diff --git a/collects/web-server/scribblings/http.scrbl b/collects/web-server/scribblings/http.scrbl index 2dcf19e8e3..c285df3c66 100644 --- a/collects/web-server/scribblings/http.scrbl +++ b/collects/web-server/scribblings/http.scrbl @@ -40,9 +40,12 @@ The @web-server implements many HTTP RFCs that are provided by this module. } @defstruct[(binding:file binding) ([filename bytes?] + [headers (listof header?)] [content bytes?])]{ Represents the uploading of the file @scheme[filename] with the id @scheme[id] - and the content @scheme[content]. + and the content @scheme[content], where @scheme[headers] are the additional headers from + the MIME envelope the file was in. (For example, the @scheme[#"Content-Type"] header may + be included by some browsers.) } @defproc[(bindings-assq [id bytes?]