diff --git a/collects/web-server/docs/reference/servlet.scrbl b/collects/web-server/docs/reference/servlet.scrbl index decd2efa6e..458f18133d 100644 --- a/collects/web-server/docs/reference/servlet.scrbl +++ b/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 -@; XXX Rename extract-binding +@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. +} + @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?] diff --git a/collects/web-server/servlet/bindings.ss b/collects/web-server/servlet/bindings.ss index d4846adf83..93d745693a 100644 --- a/collects/web-server/servlet/bindings.ss +++ b/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?)])) \ No newline at end of file + [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?)))])) \ No newline at end of file diff --git a/collects/web-server/servlet/helpers.ss b/collects/web-server/servlet/helpers.ss index 71a18534ca..9fe3793e9b 100644 --- a/collects/web-server/servlet/helpers.ss +++ b/collects/web-server/servlet/helpers.ss @@ -1,27 +1,9 @@ (module helpers mzscheme (require (lib "contract.ss") - (lib "kw.ss") - (lib "plt-match.ss")) + (lib "kw.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?] - [request-bindings (request? . -> . (listof (or/c (cons/c symbol? string?) - (cons/c symbol? bytes?))))] - [request-headers (request? . -> . (listof (cons/c symbol? string?)))])) \ No newline at end of file + [see-other redirection-status?])) \ No newline at end of file diff --git a/collects/web-server/tests/servlet/bindings-test.ss b/collects/web-server/tests/servlet/bindings-test.ss index 3169ee26ea..b40e9269e2 100644 --- a/collects/web-server/tests/servlet/bindings-test.ss +++ b/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))) diff --git a/collects/web-server/tests/servlet/helpers-test.ss b/collects/web-server/tests/servlet/helpers-test.ss index 8dee162631..0330580a69 100644 --- a/collects/web-server/tests/servlet/helpers-test.ss +++ b/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-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")))))))) \ No newline at end of file + (test-case "see-other" (check-true (redirection-status? see-other))))))) \ No newline at end of file