Exposing MIME headers to user

svn: r12431

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

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")))))
    

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)))))))

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)))

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

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        

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?]