Rearranging api

svn: r6636

collects/web-server/docs/reference/servlet.scrbl

@@ -128,8 +128,22 @@ related to HTTP request data structures.
 @file{servlet/bindings.ss} provides a number of helper functions
 for accessing request bindings.
 
-@; XXX Move in request-bindings
+@defproc[(request-bindings [req request?])
-@; XXX Rename extract-binding
+         (listof (or/c (cons/c symbol? string?)
+                       (cons/c symbol? bytes?)))]{
+ Translates the @scheme[request-bindings/raw] of @scheme[req] by
+ interpreting @scheme[bytes?] as @scheme[string?]s, except in the case
+ of @scheme[binding:file] bindings, which are left as is. Ids are then
+ translated into lowercase symbols.
+}
+                                                 
+@defproc[(request-headers [req request?])
+         (listof (cons/c symbol? string?))]{
+ Translates the @scheme[request-headers/raw] of @scheme[req] by
+ interpreting @scheme[bytes?] as @scheme[string?]s. Ids are then
+ translated into lowercase symbols.
+}                                           
+                                           
 @defproc[(extract-binding/single [id symbol?]
                                  [binds (listof (cons/c symbol? string?))])
          string?]{
@@ -150,6 +164,14 @@ for accessing request bindings.
  Otherwise, @scheme[#f].        
 }         
 
+These functions, while convenient, could introduce subtle bugs into your
+application. Examples: that they are case-insensitive could introduce
+a bug; if the data submitted is not in UTF-8 format, then the conversion
+to a string will fail; if an attacked submits a form field as if it were
+a file, when it is not, then the @scheme[request-bindings] will hold a
+@scheme[bytes?] object and your program will error; and, for file uploads
+you lose the filename.
+                  
 @; ------------------------------------------------------------
 @section[#:tag "response-structs.ss"]{HTTP Responses}
 
@@ -300,31 +322,6 @@ servlet developer.
 @file{servlet/helpers.ss} provides functions built on
 @file{servlet/web.ss} that are useful in many servlets.
 
-@; XXX Move into binding.ss
-@defproc[(request-bindings [req request?])
-         (listof (or/c (cons/c symbol? string?)
-                       (cons/c symbol? bytes?)))]{
- Translates the @scheme[request-bindings/raw] of @scheme[req] by
- interpreting @scheme[bytes?] as @scheme[string?]s, except in the case
- of @scheme[binding:file] bindings, which are left as is. Ids are then
- translated into lowercase symbols.
-}
-                                                 
-@defproc[(request-headers [req request?])
-         (listof (cons/c symbol? string?))]{
- Translates the @scheme[request-headers/raw] of @scheme[req] by
- interpreting @scheme[bytes?] as @scheme[string?]s. Ids are then
- translated into lowercase symbols.
-}                                           
-                                           
-These functions, while convenient, could introduce subtle bugs in your
-application. Examples: the fact they are case-insensitive could introduce
-a bug; if the data submitted is not in UTF-8 format, then the conversion
-to a string will fail; if an attacked submits a form field as if it were
-a file, when it is not, then the @scheme[request-bindings] will hold a
-@scheme[bytes?] object and your program will error; and, for file uploads
-you lose the filename.
-
 @; XXX Move into http/response.ss
 @; XXX Change headers to make-header struct
 @defproc[(redirect-to [uri string?]

collects/web-server/servlet/bindings.ss

@@ -1,6 +1,25 @@
 (module bindings mzscheme
   (require (lib "list.ss")
-           (lib "contract.ss"))
+           (lib "contract.ss")
+           (lib "plt-match.ss"))
+  (require "../private/util.ss"
+           "../private/request-structs.ss")
+  
+  (define (request-headers request)
+    (map (match-lambda
+           [(struct header (field value))
+            (cons (lowercase-symbol! (bytes->string/utf-8 field))
+                  (bytes->string/utf-8 value))])
+         (request-headers/raw request)))
+  (define (request-bindings request)
+    (map (match-lambda
+           [(struct binding:form (id value))
+            (cons (lowercase-symbol! (bytes->string/utf-8 id))
+                  (bytes->string/utf-8 value))]
+           [(struct binding:file (id fname value))
+            (cons (lowercase-symbol! (bytes->string/utf-8 id))
+                  value)])
+         (request-bindings/raw request)))
   
   ; extract-binding/single : sym (listof (cons str str)) -> str
   (define (extract-binding/single name bindings)
@@ -27,4 +46,7 @@
   (provide/contract
    [extract-binding/single (symbol? (listof (cons/c symbol? any/c)) . -> . any/c)]
    [extract-bindings (symbol? (listof (cons/c symbol? any/c)) . -> . (listof any/c))]
-   [exists-binding? (symbol? (listof (cons/c symbol? any/c)) . -> . boolean?)]))
+   [exists-binding? (symbol? (listof (cons/c symbol? any/c)) . -> . boolean?)]   
+   [request-bindings (request? . -> . (listof (or/c (cons/c symbol? string?)
+                                                    (cons/c symbol? bytes?))))]
+   [request-headers (request? . -> . (listof (cons/c symbol? string?)))]))

collects/web-server/servlet/helpers.ss

@@ -1,27 +1,9 @@
 (module helpers mzscheme
   (require (lib "contract.ss")
-           (lib "kw.ss")
+           (lib "kw.ss"))
-           (lib "plt-match.ss"))
   (require "../private/util.ss"
-           "../private/request-structs.ss"
            "../private/response-structs.ss")
-  
+    
-  (define (request-headers request)
-    (map (match-lambda
-           [(struct header (field value))
-            (cons (lowercase-symbol! (bytes->string/utf-8 field))
-                  (bytes->string/utf-8 value))])
-         (request-headers/raw request)))
-  (define (request-bindings request)
-    (map (match-lambda
-           [(struct binding:form (id value))
-            (cons (lowercase-symbol! (bytes->string/utf-8 id))
-                  (bytes->string/utf-8 value))]
-           [(struct binding:file (id fname value))
-            (cons (lowercase-symbol! (bytes->string/utf-8 id))
-                  value)])
-         (request-bindings/raw request)))
-  
   ; redirection-status = (make-redirection-status nat str)
   (define-struct redirection-status (code message))
   
@@ -56,7 +38,4 @@
    [redirection-status? (any/c . -> . boolean?)]
    [permanently redirection-status?]
    [temporarily redirection-status?]
-   [see-other redirection-status?]
+   [see-other redirection-status?]))
-   [request-bindings (request? . -> . (listof (or/c (cons/c symbol? string?)
-                                                    (cons/c symbol? bytes?))))]
-   [request-headers (request? . -> . (listof (cons/c symbol? string?)))]))

collects/web-server/tests/servlet/bindings-test.ss

@@ -1,5 +1,8 @@
 (module bindings-test mzscheme
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+           (lib "list.ss")
+           (lib "url.ss" "net")
+           (lib "request-structs.ss" "web-server" "private")
            (lib "bindings.ss" "web-server" "servlet"))
   (provide bindings-tests)
   
@@ -9,6 +12,56 @@
     (test-suite
      "Bindings"
      
+     (test-suite
+      "request-bindings"
+      (test-case
+       "Simple"
+       (check-equal? (request-bindings
+                      (make-request 'get (string->url "http://test.com/foo")
+                                    empty (list (make-binding:form #"key" #"val")) #f
+                                    "host" 80 "client"))
+                     '((key . "val"))))
+      (test-case
+       "Case"
+       (check-equal? (request-bindings
+                      (make-request 'get (string->url "http://test.com/foo")
+                                    empty (list (make-binding:form #"KEY" #"val")) #f
+                                    "host" 80 "client"))
+                     '((key . "val"))))
+      (test-case
+       "Multi"
+       (check-equal? (request-bindings
+                      (make-request 'get (string->url "http://test.com/foo")
+                                    empty (list (make-binding:form #"key" #"val")
+                                                (make-binding:form #"key2" #"val")) #f
+                                                                                    "host" 80 "client"))
+                     '((key . "val")
+                       (key2 . "val"))))
+      (test-case
+       "File"
+       (check-equal? (request-bindings
+                      (make-request 'get (string->url "http://test.com/foo")
+                                    empty (list (make-binding:file #"key" #"file" #"val")) #f
+                                    "host" 80 "client"))
+                     '((key . #"val")))))
+     
+     (test-suite
+      "request-headers"
+      (test-case
+       "Simple"
+       (check-equal? (request-headers
+                      (make-request 'get (string->url "http://test.com/foo")
+                                    (list (make-header #"key" #"val")) empty #f
+                                    "host" 80 "client"))
+                     '((key . "val"))))
+      (test-case
+       "Case"
+       (check-equal? (request-headers
+                      (make-request 'get (string->url "http://test.com/foo")
+                                    (list (make-header #"KEY" #"val")) empty #f
+                                    "host" 80 "client"))
+                     '((key . "val")))))
+     
      (test-case
       "exists-binding? - true"
       (check-true (exists-binding? 'foo bs)))

collects/web-server/tests/servlet/helpers-test.ss

@@ -1,9 +1,6 @@
 (module helpers-test mzscheme
   (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
-           (lib "list.ss")
-           (lib "url.ss" "net")
            (lib "response-structs.ss" "web-server" "private")
-           (lib "request-structs.ss" "web-server" "private")
            (lib "helpers.ss" "web-server" "servlet"))
   (provide helpers-tests)
   
@@ -46,54 +43,4 @@
       "redirection-status?"
       (test-case "permanently" (check-true (redirection-status? permanently)))
       (test-case "temporarily" (check-true (redirection-status? temporarily)))
-      (test-case "see-other" (check-true (redirection-status? see-other))))
+      (test-case "see-other" (check-true (redirection-status? see-other)))))))
-     
-     (test-suite
-      "request-bindings"
-      (test-case
-       "Simple"
-       (check-equal? (request-bindings
-                      (make-request 'get (string->url "http://test.com/foo")
-                                    empty (list (make-binding:form #"key" #"val")) #f
-                                    "host" 80 "client"))
-                     '((key . "val"))))
-      (test-case
-       "Case"
-       (check-equal? (request-bindings
-                      (make-request 'get (string->url "http://test.com/foo")
-                                    empty (list (make-binding:form #"KEY" #"val")) #f
-                                    "host" 80 "client"))
-                     '((key . "val"))))
-      (test-case
-       "Multi"
-       (check-equal? (request-bindings
-                      (make-request 'get (string->url "http://test.com/foo")
-                                    empty (list (make-binding:form #"key" #"val")
-                                                (make-binding:form #"key2" #"val")) #f
-                                                                                    "host" 80 "client"))
-                     '((key . "val")
-                       (key2 . "val"))))
-      (test-case
-       "File"
-       (check-equal? (request-bindings
-                      (make-request 'get (string->url "http://test.com/foo")
-                                    empty (list (make-binding:file #"key" #"file" #"val")) #f
-                                    "host" 80 "client"))
-                     '((key . #"val")))))
-     
-     (test-suite
-      "request-headers"
-      (test-case
-       "Simple"
-       (check-equal? (request-headers
-                      (make-request 'get (string->url "http://test.com/foo")
-                                    (list (make-header #"key" #"val")) empty #f
-                                    "host" 80 "client"))
-                     '((key . "val"))))
-      (test-case
-       "Case"
-       (check-equal? (request-headers
-                      (make-request 'get (string->url "http://test.com/foo")
-                                    (list (make-header #"KEY" #"val")) empty #f
-                                    "host" 80 "client"))
-                     '((key . "val"))))))))