Abstracting HTTP code to sub-module

svn: r12415

collects/tests/web-server/dispatchers/dispatch-files-test.ss

@@ -6,7 +6,7 @@
          net/url
          mzlib/list
          xml/xml
-         web-server/private/request-structs
+         web-server/http
          web-server/private/util
          web-server/dispatchers/dispatch
          (prefix-in files: web-server/dispatchers/dispatch-files)

collects/tests/web-server/dispatchers/dispatch-host-test.ss

@@ -5,7 +5,7 @@
                   make-temporary-file)
          net/url
          mzlib/list
-         web-server/private/request-structs
+         web-server/http
          web-server/dispatchers/dispatch
          (prefix-in host: web-server/dispatchers/dispatch-host))
 (provide dispatch-host-tests)

collects/tests/web-server/dispatchers/dispatch-lang-test.ss

@@ -4,7 +4,7 @@
          mzlib/etc
          mzlib/list
          web-server/dispatchers/dispatch
-         web-server/private/request-structs
+         web-server/http
          web-server/configuration/namespace
          web-server/servlet/setup
          (prefix-in servlets: web-server/dispatchers/dispatch-servlets)

collects/tests/web-server/dispatchers/dispatch-passwords-test.ss

@@ -6,7 +6,7 @@
          net/url
          mzlib/list
          mzlib/serialize
-         web-server/private/request-structs
+         web-server/http
          web-server/dispatchers/dispatch
          (prefix-in passwords: web-server/dispatchers/dispatch-passwords)
          "../util.ss")

collects/tests/web-server/dispatchers/dispatch-servlets-test.ss

@@ -3,7 +3,7 @@
          (planet "sxml.ss" ("lizorkin" "sxml.plt" 2 0))
          mzlib/etc
          mzlib/list
-         web-server/private/request-structs
+         web-server/http
          web-server/private/cache-table
          web-server/private/web-server-structs
          web-server/configuration/namespace

collects/tests/web-server/dispatchers/servlet-test-util.ss

@@ -2,7 +2,7 @@
 (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
          (planet "sxml.ss" ("lizorkin" "sxml.plt" 2 0))         
          mzlib/list
-         web-server/private/request-structs
+         web-server/http
          "../util.ss")
 (provide test-add-two-numbers
          test-double-counters

collects/tests/web-server/private/mime-types-test.ss

@@ -1,8 +1,8 @@
 #lang scheme/base
 (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
          (only-in mzlib/file make-temporary-file)
-         web-server/private/mime-types
+         web-server/http
-         web-server/private/response-structs)
+         web-server/private/mime-types)
 (provide mime-types-tests)
 
 (define test-file (make-temporary-file))

collects/tests/web-server/private/request-test.ss

@@ -3,10 +3,10 @@
          (planet "test.ss" ("schematics" "schemeunit.plt" 2))
          web-server/private/connection-manager
          web-server/private/timer
-         web-server/private/request-structs)
+         web-server/http)
 (provide request-tests)
 
-(require/expose web-server/private/request
+(require/expose web-server/http/request
                 (read-bindings&post-data/raw))
 
 ;; mock connection object for test on post body parsing

collects/tests/web-server/private/response-test.ss

@@ -4,12 +4,11 @@
          xml/xml
          (only-in mzlib/file
                   make-temporary-file)
-         web-server/private/response
+         web-server/http
-         web-server/private/request-structs
+         web-server/http/response
-         web-server/private/response-structs
          "../util.ss")
 
-(require/expose web-server/private/response
+(require/expose web-server/http/response
                 (convert-http-ranges
                  make-content-length-header
                  make-content-range-header

collects/tests/web-server/servlet/basic-auth-test.ss

@@ -1,7 +1,6 @@
 #lang scheme/base
 (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
-         web-server/private/request-structs
+         web-server/http)
-         web-server/servlet/basic-auth)
 (provide basic-auth-tests)
 
 (define basic-auth-tests

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

@@ -2,8 +2,8 @@
 (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
          mzlib/list
          net/url
-         web-server/private/request-structs
+         web-server/http
-         web-server/servlet/bindings)
+         web-server/http/bindings)
 (provide bindings-tests)
 
 (define bs `([foo . 3] [foos . 1] [foos . 2]))

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

@@ -1,7 +1,6 @@
 #lang scheme/base
 (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
-         web-server/private/response-structs
+         web-server/http
-         web-server/private/request-structs
          web-server/servlet/helpers)
 (provide helpers-tests)
 

collects/tests/web-server/util.ss

@@ -3,7 +3,7 @@
          web-server/private/connection-manager
          (only-in (planet "ssax.ss" ("lizorkin" "ssax.plt" 2 0))
                   ssax:xml->sxml)
-         web-server/private/request-structs
+         web-server/http
          web-server/private/web-server-structs
          net/url
          mzlib/pretty

collects/web-server/configuration/configuration-table-structs.ss

@@ -1,8 +1,8 @@
 #lang scheme/base
 (require mzlib/contract
          net/url)
-(require "../private/response-structs.ss"
+(require web-server/http/response-structs
-         "../private/request-structs.ss"
+         web-server/http/request-structs
          "../private/util.ss")           
 
 ; configuration-table = (make-configuration-table nat nat num host-table (listof (cons str host-table)))

collects/web-server/configuration/configuration-table.ss

@@ -3,7 +3,7 @@
          mzlib/list
          mzlib/pretty)
 (require "configuration-table-structs.ss"
-         "../servlet/bindings.ss")
+         web-server/http/bindings)
 (define configuration-table-sexpr? list?)
 
 (provide/contract

collects/web-server/configuration/responders.ss

@@ -2,8 +2,8 @@
 (require mzlib/contract
          mzlib/list
          net/url)
-(require "../private/response-structs.ss"
+(require web-server/http/response-structs
-         "../private/request-structs.ss")
+         web-server/http/request-structs)
 
 (define (format-stack-trace trace)
   `(pre

collects/web-server/default-web-root/htdocs/lang-servlets/add01.ss

@@ -1,5 +1,5 @@
 #lang scheme/base
-(require web-server/private/request-structs
+(require web-server/http
          net/url)
 (define interface-version 'stateless)
 (provide start interface-version)

collects/web-server/dispatchers/dispatch-files.ss

@@ -6,10 +6,8 @@
 
 (require "dispatch.ss"
          "../private/util.ss"
-         "../private/request-structs.ss"
+         web-server/http
-         "../private/response-structs.ss"
+         web-server/http/response
-         "../servlet/helpers.ss"
-         "../private/response.ss"
          "../dispatchers/filesystem-map.ss")
 
 (provide/contract

collects/web-server/dispatchers/dispatch-filter.ss

@@ -2,7 +2,7 @@
 (require mzlib/contract
          net/url)
 (require "dispatch.ss"
-         "../private/request-structs.ss"
+         web-server/http
          "../private/util.ss")
 (provide/contract
  [interface-version dispatcher-interface-version/c]

collects/web-server/dispatchers/dispatch-host.ss

@@ -2,7 +2,7 @@
 (require mzlib/contract
          mzlib/plt-match
          net/url
-         "../private/request-structs.ss"
+         web-server/http
          "../private/util.ss"
          "dispatch.ss")
 (provide/contract

collects/web-server/dispatchers/dispatch-lift.ss

@@ -1,9 +1,8 @@
 #lang scheme/base
 (require mzlib/contract)
 (require "dispatch.ss"
-         "../private/response.ss"
+         web-server/http
-         "../private/request-structs.ss"
+         web-server/http/response)
-         "../private/response-structs.ss")
 (provide/contract
  [interface-version dispatcher-interface-version/c]
  [make ((request? . -> . response?) . -> . dispatcher/c)])

collects/web-server/dispatchers/dispatch-log.ss

@@ -6,7 +6,7 @@
          mzlib/plt-match
          scheme/contract)
 (require "dispatch.ss"
-         "../private/request-structs.ss")  
+         web-server/http)  
 (define format-req/c (request? . -> . string?))
 
 (provide/contract

collects/web-server/dispatchers/dispatch-passwords.ss

@@ -5,10 +5,8 @@
 (require "dispatch.ss"
          "../private/util.ss"
          "../configuration/responders.ss"
-         "../private/request-structs.ss"
+         web-server/http
-         "../private/response-structs.ss"
+         web-server/http/response)
-         "../servlet/basic-auth.ss"
-         "../private/response.ss")  
 
 (define denied?/c (request? . -> . (or/c false/c string?)))
 (define authorized?/c (string? (or/c false/c bytes?) (or/c false/c bytes?) . -> . (or/c false/c string?)))

collects/web-server/dispatchers/dispatch-pathprocedure.ss

@@ -3,9 +3,8 @@
          net/url)
 (require "dispatch.ss"
          "../private/util.ss"
-         "../private/response.ss"
+         web-server/http
-         "../private/request-structs.ss"
+         web-server/http/response)
-         "../private/response-structs.ss")
 (provide/contract
  [interface-version dispatcher-interface-version/c]
  [make (string? (request? . -> . response?) . -> . dispatcher/c)])

collects/web-server/dispatchers/dispatch-servlets.ss

@@ -2,9 +2,8 @@
 (require scheme/contract)
 (require web-server/servlet/setup
          web-server/managers/manager
-         web-server/private/response
+         web-server/http
-         web-server/private/response-structs
+         web-server/http/response
-         web-server/private/request-structs
          net/url
          web-server/dispatchers/dispatch
          web-server/dispatchers/filesystem-map

collects/web-server/dispatchers/dispatch.ss

@@ -1,7 +1,7 @@
 #lang scheme/base
 (require scheme/contract)
 (require "../private/connection-manager.ss"
-         "../private/request-structs.ss")
+         web-server/http)
 
 (define dispatcher/c
   (connection? request? . -> . void))

collects/web-server/formlets/input.ss

@@ -1,5 +1,5 @@
 #lang scheme
-(require web-server/private/request-structs
+(require web-server/http
          "lib.ss")
 
 (define (next-name i)

collects/web-server/formlets/lib.ss

@@ -1,5 +1,5 @@
 #lang scheme
-(require web-server/private/request-structs
+(require web-server/http
          xml)
 
 ; Combinators

collects/web-server/http.ss

@@ -0,0 +1,9 @@
+#lang scheme
+(require web-server/http/basic-auth
+         web-server/http/request-structs
+         web-server/http/response-structs
+         web-server/http/redirect)
+(provide (all-from-out web-server/http/basic-auth
+                       web-server/http/request-structs
+                       web-server/http/response-structs
+                       web-server/http/redirect))

collects/web-server/http/basic-auth.ss

@@ -1,8 +1,8 @@
 #lang scheme/base
 (require mzlib/contract
          mzlib/plt-match
-         net/base64)
+         net/base64
-(require "../private/request-structs.ss")
+         web-server/http/request-structs)
 
 (define (extract-user-pass headers)
   (match (headers-assq* #"Authorization" headers)

collects/web-server/http/bindings.ss

@@ -1,9 +1,9 @@
 #lang scheme/base
 (require mzlib/list
          mzlib/contract
-         mzlib/plt-match)
+         mzlib/plt-match
-(require "../private/util.ss"
+         web-server/private/util
-         "../private/request-structs.ss")
+         web-server/http/request-structs)
 
 (define (request-headers request)
   (map (match-lambda

collects/web-server/http/redirect.ss

@@ -0,0 +1,32 @@
+#lang scheme/base
+(require scheme/contract)
+(require web-server/http/response-structs
+         web-server/http/request-structs)
+
+; redirection-status = (make-redirection-status nat str)
+(define-struct redirection-status (code message))
+
+(define permanently (make-redirection-status 301 "Moved Permanently"))
+(define temporarily (make-redirection-status 302 "Moved Temporarily"))
+(define see-other (make-redirection-status 303 "See Other"))
+
+; : str [redirection-status] -> response
+(define(redirect-to 
+        uri
+        [perm/temp temporarily]
+        #:headers [headers (list)])
+  (make-response/full (redirection-status-code perm/temp)
+                      (redirection-status-message perm/temp)
+                      (current-seconds) #"text/html"
+                      (list* (make-header #"Location" (string->bytes/utf-8 uri))
+                             headers)
+                      (list)))
+
+(provide/contract
+ [redirect-to
+  (->* (string?) (redirection-status? #:headers (listof header?))
+       response/full?)]
+ [redirection-status? (any/c . -> . boolean?)]
+ [permanently redirection-status?]
+ [temporarily redirection-status?]
+ [see-other redirection-status?])

collects/web-server/http/request.ss

@@ -3,10 +3,10 @@
          mzlib/plt-match
          net/url
          mzlib/list
-         net/uri-codec)
+         net/uri-codec
-(require "util.ss"
+         web-server/private/util
-         "connection-manager.ss"
+         web-server/private/connection-manager
-         "../private/request-structs.ss")
+         web-server/http/request-structs)
 
 (provide/contract
  [rename ext:read-request read-request

collects/web-server/http/response-structs.ss

@@ -1,7 +1,7 @@
 #lang scheme/base
 (require mzlib/contract
          xml/xml
-         "request-structs.ss")
+         web-server/http/request-structs)
 
 (define TEXT/HTML-MIME-TYPE #"text/html; charset=utf-8")
 

collects/web-server/http/response.ss

@@ -7,10 +7,10 @@
          (only-in srfi/1/list fold filter-map)
          (only-in srfi/13/string string-join)
          xml/xml
-         "connection-manager.ss"
+         web-server/private/connection-manager
-         "../private/request-structs.ss"
+         web-server/http/request-structs
-         "../private/response-structs.ss"
+         web-server/http/response-structs
-         "util.ss")
+         web-server/private/util)
 
 (provide/contract
  [rename ext:output-response output-response (connection? response? . -> . void)]
@@ -49,8 +49,7 @@
 
 ;; Notes:
 ;; 1. close? is a boolean which corresponds roughly to the protocol version.
-;;    #t |-> 1.0 and #f |-> 1.1. See function close-connection? in
+;;    #t |-> 1.0 and #f |-> 1.1. See function close-connection?
-;;    private/request.ss
 ;;
 ;; 2. In the case of a chunked response when close? = #f, then the response
 ;;    must be compliant with http 1.0. In this case the chunked response is

collects/web-server/lang/lang-api.ss

@@ -1,8 +1,6 @@
 #lang scheme
 (require net/url
-         "../private/request-structs.ss"
+         web-server/http
-         "../private/response-structs.ss"
-         "../servlet/helpers.ss"
          "abort-resume.ss"
          "web.ss"
          "web-cells.ss"
@@ -10,13 +8,11 @@
          "file-box.ss"
          "web-extras.ss")
 (provide (except-out (all-from-out scheme) #%module-begin)
-         (all-from-out net/url)
+         (all-from-out net/url
-         (all-from-out "../private/request-structs.ss")
+                       web-server/http
-         (all-from-out "../private/response-structs.ss")
+                       "abort-resume.ss"
-         (all-from-out "../servlet/helpers.ss")
+                       "web.ss"
-         (all-from-out "abort-resume.ss")
+                       "web-cells.ss"
-         (all-from-out "web.ss")
+                       "web-param.ss"
-         (all-from-out "web-cells.ss")
+                       "file-box.ss"
-         (all-from-out "web-param.ss")
+                       "web-extras.ss"))
-         (all-from-out "file-box.ss")
-         (all-from-out "web-extras.ss"))

collects/web-server/lang/web-extras.ss

@@ -1,10 +1,8 @@
 #lang scheme/base
 (require net/url
          scheme/contract
-         (for-template "web.ss")
          "web.ss"
-         web-server/private/request-structs
+         web-server/http)
-         "../servlet/helpers.ss")
 (provide/contract
  [redirect/get (-> request?)])  
 

collects/web-server/lang/web.ss

@@ -2,11 +2,9 @@
 (require net/url
          scheme/contract
          scheme/serialize
-         web-server/private/request-structs
+         web-server/http
-         web-server/private/response-structs
          web-server/private/define-closure
          web-server/private/servlet         
-         "../private/request-structs.ss"
          "abort-resume.ss"
          "stuff-url.ss"
          "../private/url-param.ss")

collects/web-server/private/mime-types.ss

@@ -3,7 +3,7 @@
          mzlib/plt-match
          mzlib/string)
 (require "util.ss"
-         "response-structs.ss")
+         web-server/http)
 (provide/contract
  [read-mime-types (path-string? . -> . hash?)]
  [make-path->mime-type (path-string? . -> . (path? . -> . bytes?))])

collects/web-server/private/servlet.ss

@@ -1,8 +1,7 @@
 #lang scheme/base
 (require scheme/contract)
 (require "../managers/manager.ss"
-         "../private/request-structs.ss"
+         web-server/http)
-         "../private/response-structs.ss")
 
 (define servlet-prompt (make-continuation-prompt-tag 'servlet))
 (define-struct (exn:fail:servlet:instance exn:fail) ())

collects/web-server/scribblings/dispatchers.scrbl

@@ -245,8 +245,7 @@ a URL that refreshes the password file, servlet cache, etc.}
               @elem{defines a dispatcher constructor
                     that performs HTTP Basic authentication filtering.}]{
 
-@(require (for-label web-server/private/request-structs
+@(require (for-label web-server/http
-                     web-server/private/response-structs
                      net/url
                      web-server/configuration/responders))
 

collects/web-server/scribblings/http.scrbl

@@ -0,0 +1,272 @@
+#lang scribble/doc
+@(require "web-server.ss")
+
+@title[#:tag "http"
+       #:style 'toc]{HTTP}
+
+@defmodule[web-server/http]
+
+The @web-server implements many HTTP RFCs that are provided by this module.
+
+@local-table-of-contents[]
+
+@; ------------------------------------------------------------
+@section[#:tag "request-structs.ss"]{Requests}
+@(require (for-label web-server/http/request-structs))
+
+@defmodule[web-server/http/request-structs]
+
+@defstruct[header ([field bytes?]
+                   [value bytes?])]{
+ Represents a header of @scheme[field] to @scheme[value].
+}
+
+@defproc[(headers-assq [id bytes?] [heads (listof header?)])
+         (or/c false/c header?)]{
+ Returns the header with a field equal to @scheme[id] from @scheme[heads] or @scheme[#f].
+}
+
+@defproc[(headers-assq* [id bytes?] [heads (listof header?)])
+         (or/c false/c header?)]{
+ Returns the header with a field case-insensitively equal to @scheme[id] from @scheme[heads] or @scheme[#f].
+         
+ You almost @bold{always} want to use this, rather than @scheme[headers-assq] because Web browsers may send headers with arbitrary casing.
+}
+
+@defstruct[binding ([id bytes?])]{Represents a binding of @scheme[id].}
+
+@defstruct[(binding:form binding) ([value bytes?])]{
+ Represents a form binding of @scheme[id] to @scheme[value].
+}
+
+@defstruct[(binding:file binding) ([filename bytes?]
+                                   [content bytes?])]{
+ Represents the uploading of the file @scheme[filename] with the id @scheme[id]
+ and the content @scheme[content].
+}
+
+@defproc[(bindings-assq [id bytes?]
+                        [binds (listof binding?)])
+         (or/c false/c binding?)]{
+ Returns the binding with an id equal to @scheme[id] from @scheme[binds] or @scheme[#f].
+}
+
+@defstruct[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?])]{
+ An HTTP @scheme[method] request to @scheme[uri] from @scheme[client-ip]
+ to the server at @scheme[host-ip]:@scheme[host-port] with @scheme[headers/raw]
+ headers, @scheme[bindings/raw] GET and POST queries and @scheme[post-data/raw]
+ POST data.
+ 
+ You are @bold{unlikely to need to construct} a request struct.
+}
+                                         
+Here is an example typical of what you will find in many applications:
+@schemeblock[
+(define (get-number req)
+  (match
+    (bindings-assq 
+      #"number"
+      (request-bindings/raw req))
+    [(? binding:form? b)
+     (string->number
+      (bytes->string/utf-8
+       (binding:form-value b)))]
+    [_
+     (get-number (request-number))]))
+]
+
+@; ------------------------------------------------------------
+@section[#:tag "bindings.ss"]{Bindings}
+@(require (for-label web-server/http/bindings))
+
+@defmodule[web-server/http/bindings]
+
+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 attacker 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. @bold{Therefore, we recommend against their use, but
+they are provided for compatibility with old code.}
+
+@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?]{
+ Returns the single binding associated with @scheme[id] in the a-list @scheme[binds]
+ if there is exactly one binding. Otherwise raises @scheme[exn:fail].
+}
+
+@defproc[(extract-bindings [id symbol?]
+                           [binds (listof (cons/c symbol? string?))])
+         (listof string?)]{
+ Returns a list of all the bindings of @scheme[id] in the a-list @scheme[binds].
+}
+
+@defproc[(exists-binding? [id symbol?]
+                          [binds (listof (cons/c symbol? string))])
+         boolean?]{
+ Returns @scheme[#t] if @scheme[binds] contains a binding for @scheme[id].
+ Otherwise, @scheme[#f].
+}
+                  
+Here is an example typical of what you will find in many applications:
+@schemeblock[
+(define (get-number req)
+  (string->number
+   (extract-binding/single
+    'number
+    (request-bindings req))))
+]
+
+@; ------------------------------------------------------------
+@section[#:tag "response-structs.ss"]{Responses}
+@(require (for-label web-server/http/response-structs))
+
+@defmodule[web-server/http/response-structs]
+
+@defstruct[response/basic
+           ([code number?]
+            [message string?]
+            [seconds number?]
+            [mime bytes?]
+            [headers (listof header?)])]{
+ A basic HTTP response containing no body. @scheme[code] is the response code,
+ @scheme[message] the message, @scheme[seconds] the generation time, @scheme[mime]
+ the MIME type of the file, and @scheme[extras] are the extra headers, in addition
+ to those produced by the server.
+ 
+ Example:
+ @schemeblock[
+  (make-response/basic
+   301 "Moved Permanently"
+   (current-seconds) TEXT/HTML-MIME-TYPE
+   (list (make-header #"Location"
+                      #"http://www.plt-scheme.org/downloads")))
+ ]
+}
+
+@defstruct[(response/full response/basic)
+           ([body (listof (or/c string? bytes?))])]{
+ As with @scheme[response/basic], except with @scheme[body] as the response
+ body.
+
+ Example:
+ @schemeblock[
+  (make-response/full
+   301 "Moved Permanently"
+   (current-seconds) TEXT/HTML-MIME-TYPE
+   (list (make-header #"Location"
+                      #"http://www.plt-scheme.org/downloads"))
+   (list #"<html><body><p>"
+         #"Please go to <a href=\""
+         #"http://www.plt-scheme.org/downloads"
+         #"\">here</a> instead."
+         #"</p></body></html>"))
+ ]
+}
+
+@defstruct[(response/incremental response/basic)
+           ([generator ((() (listof (or/c bytes? string?)) . ->* . any) . -> . any)])]{
+ As with @scheme[response/basic], except with @scheme[generator] as a function that is
+ called to generate the response body, by being given an @scheme[output-response] function
+ that outputs the content it is called with.
+ 
+ Here is a short example:
+ @schemeblock[
+  (make-response/incremental
+    200 "OK" (current-seconds)
+    #"application/octet-stream"
+    (list (make-header #"Content-Disposition"
+                       #"attachement; filename=\"file\""))
+    (lambda (send/bytes)
+      (send/bytes #"Some content")
+      (send/bytes)
+      (send/bytes #"Even" #"more" #"content!")
+      (send/bytes "Now we're done")))
+ ]
+}
+
+@defproc[(response? [v any/c])
+         boolean?]{
+ Checks if @scheme[v] is a valid response. A response is either:
+ @itemize[
+  @item{A @scheme[response/basic] structure.}
+  @item{A value matching the contract @scheme[(cons/c (or/c bytes? string?) (listof (or/c bytes? string?)))].}
+  @item{A value matching @scheme[xexpr?].}
+ ]
+}
+
+@defthing[TEXT/HTML-MIME-TYPE bytes?]{Equivalent to @scheme[#"text/html; charset=utf-8"].}
+
+@warning{If you include a Content-Length header in a response that is inaccurate, there @bold{will be an error} in
+transmission that the server @bold{will not catch}.}
+
+                  
+@; ------------------------------------------------------------
+@section[#:tag "redirect.ss"]{Redirect}
+@(require (for-label web-server/http/redirect))
+
+@defmodule[web-server/http/redirect]
+
+@defproc[(redirect-to [uri string?]
+                      [perm/temp redirection-status? temporarily]
+                      [#:headers headers (listof header?) (list)])
+         response?]{
+ Generates an HTTP response that redirects the browser to @scheme[uri],
+ while including the @scheme[headers] in the response.
+ 
+ Example:
+ @scheme[(redirect-to "http://www.add-three-numbers.com" permanently)]
+}
+
+@defproc[(redirection-status? [v any/c])
+         boolean?]{
+ Determines if @scheme[v] is one of the following values.
+}
+
+@defthing[permanently redirection-status?]{A @scheme[redirection-status?] for permanent redirections.}
+
+@defthing[temporarily redirection-status?]{A @scheme[redirection-status?] for temporary redirections.}
+
+@defthing[see-other redirection-status?]{A @scheme[redirection-status?] for "see-other" redirections.}
+
+@; ------------------------------------------------------------
+@section[#:tag "basic-auth.ss"]{Basic Authentication}
+@(require (for-label web-server/http/basic-auth))
+
+@defmodule[web-server/http/basic-auth]
+
+An implementation of HTTP Basic Authentication.
+
+@defproc[(extract-user-pass [heads (listof header?)])
+         (or/c false/c (cons/c bytes? bytes?))]{
+ Returns a pair of the username and password from the authentication
+ header in @scheme[heads] if they are present, or @scheme[#f].
+ 
+ Example:
+ @scheme[(extract-user-pass (request-headers/raw req))] might return @scheme[(cons #"aladin" #"open sesame")].
+}

collects/web-server/scribblings/servlet.scrbl

@@ -123,230 +123,6 @@ Equivalent to @scheme[(((request? . -> . any/c)) (expiration-handler/c) . opt->
 This is what @scheme[send/suspend/dispatch] gives to its function argument.
 }
 
-@; ------------------------------------------------------------
-@section[#:tag "request-structs.ss"]{HTTP Requests}
-@(require (for-label web-server/private/request-structs))
-
-@defmodule[web-server/private/request-structs]
-
-@filepath{private/request-structs.ss} provides a number of structures and functions
-related to HTTP request data structures.
-
-@defstruct[header ([field bytes?]
-                   [value bytes?])]{
- Represents a header of @scheme[field] to @scheme[value].
-}
-
-@defproc[(headers-assq [id bytes?] [heads (listof header?)])
-         (or/c false/c header?)]{
- Returns the header with a field equal to @scheme[id] from @scheme[heads] or @scheme[#f].
-}
-
-@defproc[(headers-assq* [id bytes?] [heads (listof header?)])
-         (or/c false/c header?)]{
- Returns the header with a field case-insensitively equal to @scheme[id] from @scheme[heads] or @scheme[#f].
-         
- You almost @bold{always} want to use this, rather than @scheme[headers-assq] because Web browsers may send headers with arbitrary casing.
-}
-
-@defstruct[binding ([id bytes?])]{Represents a binding of @scheme[id].}
-
-@defstruct[(binding:form binding) ([value bytes?])]{
- Represents a form binding of @scheme[id] to @scheme[value].
-}
-
-@defstruct[(binding:file binding) ([filename bytes?]
-                                   [content bytes?])]{
- Represents the uploading of the file @scheme[filename] with the id @scheme[id]
- and the content @scheme[content].
-}
-
-@defproc[(bindings-assq [id bytes?]
-                        [binds (listof binding?)])
-         (or/c false/c binding?)]{
- Returns the binding with an id equal to @scheme[id] from @scheme[binds] or @scheme[#f].
-}
-
-@defstruct[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?])]{
- An HTTP @scheme[method] request to @scheme[uri] from @scheme[client-ip]
- to the server at @scheme[host-ip]:@scheme[host-port] with @scheme[headers/raw]
- headers, @scheme[bindings/raw] GET and POST queries and @scheme[post-data/raw]
- POST data.
- 
- You are @bold{unlikely to need to construct} a request struct.
-}
-                                         
-Here is an example typical of what you will find in many applications:
-@schemeblock[
-(define (get-number req)
-  (match
-    (bindings-assq 
-      #"number"
-      (request-bindings/raw req))
-    [(? binding:form? b)
-     (string->number
-      (bytes->string/utf-8
-       (binding:form-value b)))]
-    [_
-     (get-number (request-number))]))
-]
-
-@; ------------------------------------------------------------
-@section[#:tag "bindings.ss"]{Request Bindings}
-@(require (for-label web-server/servlet/bindings))
-
-@defmodule[web-server/servlet/bindings]
-
-@filepath{servlet/bindings.ss} provides a number of helper functions
-for accessing request bindings.
-
-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 attacker 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. @bold{Therefore, we recommend against their use, but
-they are provided for compatibility with old code.}
-
-@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?]{
- Returns the single binding associated with @scheme[id] in the a-list @scheme[binds]
- if there is exactly one binding. Otherwise raises @scheme[exn:fail].
-}
-
-@defproc[(extract-bindings [id symbol?]
-                           [binds (listof (cons/c symbol? string?))])
-         (listof string?)]{
- Returns a list of all the bindings of @scheme[id] in the a-list @scheme[binds].
-}
-
-@defproc[(exists-binding? [id symbol?]
-                          [binds (listof (cons/c symbol? string))])
-         boolean?]{
- Returns @scheme[#t] if @scheme[binds] contains a binding for @scheme[id].
- Otherwise, @scheme[#f].
-}
-                  
-Here is an example typical of what you will find in many applications:
-@schemeblock[
-(define (get-number req)
-  (string->number
-   (extract-binding/single
-    'number
-    (request-bindings req))))
-]
-
-@; ------------------------------------------------------------
-@section[#:tag "response-structs.ss"]{HTTP Responses}
-@(require (for-label web-server/private/response-structs))
-
-@defmodule[web-server/private/response-structs]
-
-@filepath{private/response-structs.ss} provides structures and functions related to
-HTTP responses.
-
-@defstruct[response/basic
-           ([code number?]
-            [message string?]
-            [seconds number?]
-            [mime bytes?]
-            [headers (listof header?)])]{
- A basic HTTP response containing no body. @scheme[code] is the response code,
- @scheme[message] the message, @scheme[seconds] the generation time, @scheme[mime]
- the MIME type of the file, and @scheme[extras] are the extra headers, in addition
- to those produced by the server.
- 
- Example:
- @schemeblock[
-  (make-response/basic
-   301 "Moved Permanently"
-   (current-seconds) TEXT/HTML-MIME-TYPE
-   (list (make-header #"Location"
-                      #"http://www.plt-scheme.org/downloads")))
- ]
-}
-
-@defstruct[(response/full response/basic)
-           ([body (listof (or/c string? bytes?))])]{
- As with @scheme[response/basic], except with @scheme[body] as the response
- body.
-
- Example:
- @schemeblock[
-  (make-response/full
-   301 "Moved Permanently"
-   (current-seconds) TEXT/HTML-MIME-TYPE
-   (list (make-header #"Location"
-                      #"http://www.plt-scheme.org/downloads"))
-   (list #"<html><body><p>"
-         #"Please go to <a href=\""
-         #"http://www.plt-scheme.org/downloads"
-         #"\">here</a> instead."
-         #"</p></body></html>"))
- ]
-}
-
-@defstruct[(response/incremental response/basic)
-           ([generator ((() (listof (or/c bytes? string?)) . ->* . any) . -> . any)])]{
- As with @scheme[response/basic], except with @scheme[generator] as a function that is
- called to generate the response body, by being given an @scheme[output-response] function
- that outputs the content it is called with.
- 
- Here is a short example:
- @schemeblock[
-  (make-response/incremental
-    200 "OK" (current-seconds)
-    #"application/octet-stream"
-    (list (make-header #"Content-Disposition"
-                       #"attachement; filename=\"file\""))
-    (lambda (send/bytes)
-      (send/bytes #"Some content")
-      (send/bytes)
-      (send/bytes #"Even" #"more" #"content!")
-      (send/bytes "Now we're done")))
- ]
-}
-
-@defproc[(response? [v any/c])
-         boolean?]{
- Checks if @scheme[v] is a valid response. A response is either:
- @itemize[
-  @item{A @scheme[response/basic] structure.}
-  @item{A value matching the contract @scheme[(cons/c (or/c bytes? string?) (listof (or/c bytes? string?)))].}
-  @item{A value matching @scheme[xexpr?].}
- ]
-}
-
-@defthing[TEXT/HTML-MIME-TYPE bytes?]{Equivalent to @scheme[#"text/html; charset=utf-8"].}
-
-@warning{If you include a Content-Length header in a response that is inaccurate, there @bold{will be an error} in
-transmission that the server @bold{will not catch}.}
-
 @; ------------------------------------------------------------
 @section[#:tag "web.ss"]{Web}
 @(require (for-label web-server/servlet/web))
@@ -502,31 +278,6 @@ functions of interest for the servlet developer.}
 
 @defmodule[web-server/servlet/helpers]
 
-@filepath{servlet/helpers.ss} provides functions built on
-@filepath{servlet/web.ss} that are useful in many servlets.
-
-@defproc[(redirect-to [uri string?]
-                      [perm/temp redirection-status? temporarily]
-                      [#:headers headers (listof header?) (list)])
-         response?]{
- Generates an HTTP response that redirects the browser to @scheme[uri],
- while including the @scheme[headers] in the response.
- 
- Example:
- @scheme[(redirect-to "http://www.add-three-numbers.com" permanently)]
-}
-
-@defproc[(redirection-status? [v any/c])
-         boolean?]{
- Determines if @scheme[v] is one of the following values.
-}
-
-@defthing[permanently redirection-status?]{A @scheme[redirection-status?] for permanent redirections.}
-
-@defthing[temporarily redirection-status?]{A @scheme[redirection-status?] for temporary redirections.}
-
-@defthing[see-other redirection-status?]{A @scheme[redirection-status?] for "see-other" redirections.}
-
 @defproc[(with-errors-to-browser [send/finish-or-back (response? . -> . request?)]
                                  [thunk (-> any)])
          any]{
@@ -542,24 +293,6 @@ functions of interest for the servlet developer.}
  ]
 }
 
-@; ------------------------------------------------------------
-@section[#:tag "basic-auth.ss"]{Basic Authentication}
-@(require (for-label web-server/servlet/basic-auth))
-
-@defmodule[web-server/servlet/basic-auth]
-
-@filepath{servlet/basic-auth.ss} provides a function for helping with
-implementation of HTTP Basic Authentication.
-
-@defproc[(extract-user-pass [heads (listof header?)])
-         (or/c false/c (cons/c bytes? bytes?))]{
- Returns a pair of the username and password from the authentication
- header in @scheme[heads] if they are present, or @scheme[#f].
- 
- Example:
- @scheme[(extract-user-pass (request-headers/raw req))] might return @scheme[(cons #"aladin" #"open sesame")].
-}
-
 @; ------------------------------------------------------------
 @section[#:tag "web-cells.ss"]{Web Cells}
 @(require (for-label web-server/servlet/web-cells))

collects/web-server/scribblings/web-server.scrbl

@@ -12,6 +12,8 @@ develop Web applications in Scheme.
 
 @include-section["running.scrbl"]
 
+@include-section["http.scrbl"]
+
 @include-section["servlet.scrbl"]
 @include-section["lang.scrbl"]
 

collects/web-server/servlet-env.ss

@@ -10,8 +10,7 @@
          web-server/private/servlet
          web-server/configuration/namespace
          web-server/private/cache-table 
-         web-server/private/request-structs
+         web-server/http
-         web-server/private/response-structs
          web-server/private/util
          web-server/configuration/responders
          web-server/dispatchers/dispatch

collects/web-server/servlet.ss

@@ -1,17 +1,13 @@
 #lang scheme/base
-(require "servlet/helpers.ss"
+(require web-server/servlet/helpers
-         "servlet/web-cells.ss"
+         web-server/servlet/web-cells
-         "servlet/bindings.ss"
+         web-server/http/bindings
-         "servlet/basic-auth.ss"
+         web-server/http
-         "servlet/web.ss"
+         web-server/servlet/servlet-structs
-         "servlet/servlet-structs.ss"
+         web-server/servlet/web)
-         "private/response-structs.ss"
+(provide (all-from-out web-server/servlet/helpers
-         "private/request-structs.ss")
+                       web-server/servlet/web-cells
-(provide (all-from-out "servlet/web.ss")
+                       web-server/http/bindings
-         (all-from-out "servlet/web-cells.ss")
+                       web-server/http
-         (all-from-out "servlet/helpers.ss")
+                       web-server/servlet/servlet-structs
-         (all-from-out "servlet/bindings.ss")
+                       web-server/servlet/web))
-         (all-from-out "servlet/basic-auth.ss")
-         (all-from-out "servlet/servlet-structs.ss")
-         (all-from-out "private/response-structs.ss")
-         (all-from-out "private/request-structs.ss"))

collects/web-server/servlet/helpers.ss

@@ -1,27 +1,7 @@
 #lang scheme/base
 (require scheme/contract)
 (require "../private/util.ss"
-         "../private/request-structs.ss"
+         web-server/http)
-         "../private/response-structs.ss")
-
-; redirection-status = (make-redirection-status nat str)
-(define-struct redirection-status (code message))
-
-(define permanently (make-redirection-status 301 "Moved Permanently"))
-(define temporarily (make-redirection-status 302 "Moved Temporarily"))
-(define see-other (make-redirection-status 303 "See Other"))
-
-; : str [redirection-status] -> response
-(define(redirect-to 
-        uri
-        [perm/temp temporarily]
-        #:headers [headers (list)])
-  (make-response/full (redirection-status-code perm/temp)
-                      (redirection-status-message perm/temp)
-                      (current-seconds) #"text/html"
-                      (list* (make-header #"Location" (string->bytes/utf-8 uri))
-                             headers)
-                      (list)))
 
 (define (with-errors-to-browser send/finish-or-back thunk)
   (with-handlers ([exn? (lambda (exn)
@@ -33,13 +13,6 @@
     (thunk)))
 
 (provide/contract
- [redirect-to
-  (->* (string?) (redirection-status? #:headers (listof header?))
-       response/full?)]
- [redirection-status? (any/c . -> . boolean?)]
- [permanently redirection-status?]
- [temporarily redirection-status?]
- [see-other redirection-status?]
  [with-errors-to-browser
   ((response? . -> . request?)
    (-> any)

collects/web-server/servlet/servlet-structs.ss

@@ -1,7 +1,6 @@
 #lang scheme/base
-(require scheme/contract)
+(require scheme/contract
-(require "../private/request-structs.ss"
+         web-server/http)  
-         "../private/response-structs.ss")  
 
 (define k-url?
   string?)

collects/web-server/servlet/setup.ss

@@ -6,8 +6,7 @@
          web-server/managers/none
          (only-in web-server/lang/web
                   initialize-servlet)
-         web-server/private/response-structs
+         web-server/http
-         web-server/private/request-structs
          web-server/servlet/web
          web-server/configuration/namespace
          web-server/private/web-server-structs
@@ -78,8 +77,7 @@
 
 (define common-module-specs
   '(web-server/private/servlet
-    web-server/private/request-structs
+    web-server/http))
-    web-server/private/response-structs))
 
 (define servlet-module-specs
   '(web-server/servlet/web

collects/web-server/servlet/web.ss

@@ -3,11 +3,9 @@
 (require "../managers/manager.ss"
          "../private/util.ss"
          "../private/servlet.ss"
-         "../servlet/helpers.ss"
          "../servlet/web-cells.ss"
          "../servlet/servlet-structs.ss"
-         "../private/response-structs.ss"
+         web-server/http)
-         "../private/request-structs.ss")
 
 (provide servlet-prompt)
 

collects/web-server/web-server-unit.ss

@@ -9,7 +9,7 @@
          "private/mime-types.ss"
          "configuration/configuration-table-structs.ss"
          "private/cache-table.ss"
-         (prefix-in http: "private/request.ss"))
+         (prefix-in http: web-server/http/request))
 (require "dispatchers/dispatch.ss"
          web-server/servlet/setup
          (prefix-in fsmap: "dispatchers/filesystem-map.ss")

collects/web-server/web-server.ss

@@ -10,7 +10,7 @@
          "web-config-sig.ss"
          "web-server-sig.ss"
          "web-server-unit.ss"
-         (prefix-in http: "private/request.ss"))
+         (prefix-in http: web-server/http/request))
 (provide/contract
  [serve
   (->* (#:dispatch dispatcher/c)