From d0a5616cb037f0e1254fe20a1eb0eda52aaede49 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 12 Nov 2008 18:44:29 +0000 Subject: [PATCH] Abstracting HTTP code to sub-module svn: r12415 --- .../dispatchers/dispatch-files-test.ss | 2 +- .../dispatchers/dispatch-host-test.ss | 2 +- .../dispatchers/dispatch-lang-test.ss | 2 +- .../dispatchers/dispatch-passwords-test.ss | 2 +- .../dispatchers/dispatch-servlets-test.ss | 2 +- .../dispatchers/servlet-test-util.ss | 2 +- .../web-server/private/mime-types-test.ss | 4 +- .../tests/web-server/private/request-test.ss | 4 +- .../tests/web-server/private/response-test.ss | 7 +- .../web-server/servlet/basic-auth-test.ss | 3 +- .../tests/web-server/servlet/bindings-test.ss | 4 +- .../tests/web-server/servlet/helpers-test.ss | 3 +- collects/tests/web-server/util.ss | 2 +- .../configuration-table-structs.ss | 4 +- .../configuration/configuration-table.ss | 2 +- .../web-server/configuration/responders.ss | 4 +- .../htdocs/lang-servlets/add01.ss | 2 +- .../web-server/dispatchers/dispatch-files.ss | 6 +- .../web-server/dispatchers/dispatch-filter.ss | 2 +- .../web-server/dispatchers/dispatch-host.ss | 2 +- .../web-server/dispatchers/dispatch-lift.ss | 5 +- .../web-server/dispatchers/dispatch-log.ss | 2 +- .../dispatchers/dispatch-passwords.ss | 6 +- .../dispatchers/dispatch-pathprocedure.ss | 5 +- .../dispatchers/dispatch-servlets.ss | 5 +- collects/web-server/dispatchers/dispatch.ss | 2 +- collects/web-server/formlets/input.ss | 2 +- collects/web-server/formlets/lib.ss | 2 +- collects/web-server/http.ss | 9 + .../{servlet => http}/basic-auth.ss | 4 +- .../web-server/{servlet => http}/bindings.ss | 6 +- collects/web-server/http/redirect.ss | 32 +++ .../{private => http}/request-structs.ss | 0 .../web-server/{private => http}/request.ss | 8 +- .../{private => http}/response-structs.ss | 2 +- .../web-server/{private => http}/response.ss | 11 +- collects/web-server/lang/lang-api.ss | 22 +- collects/web-server/lang/web-extras.ss | 4 +- collects/web-server/lang/web.ss | 6 +- collects/web-server/private/mime-types.ss | 2 +- collects/web-server/private/servlet.ss | 3 +- .../web-server/scribblings/dispatchers.scrbl | 3 +- collects/web-server/scribblings/http.scrbl | 272 ++++++++++++++++++ collects/web-server/scribblings/servlet.scrbl | 267 ----------------- .../web-server/scribblings/web-server.scrbl | 2 + collects/web-server/servlet-env.ss | 3 +- collects/web-server/servlet.ss | 28 +- collects/web-server/servlet/helpers.ss | 29 +- .../web-server/servlet/servlet-structs.ss | 5 +- collects/web-server/servlet/setup.ss | 6 +- collects/web-server/servlet/web.ss | 4 +- collects/web-server/web-server-unit.ss | 2 +- collects/web-server/web-server.ss | 2 +- 53 files changed, 406 insertions(+), 416 deletions(-) create mode 100644 collects/web-server/http.ss rename collects/web-server/{servlet => http}/basic-auth.ss (93%) rename collects/web-server/{servlet => http}/bindings.ss (95%) create mode 100644 collects/web-server/http/redirect.ss rename collects/web-server/{private => http}/request-structs.ss (100%) rename collects/web-server/{private => http}/request.ss (98%) rename collects/web-server/{private => http}/response-structs.ss (97%) rename collects/web-server/{private => http}/response.ss (98%) create mode 100644 collects/web-server/scribblings/http.scrbl diff --git a/collects/tests/web-server/dispatchers/dispatch-files-test.ss b/collects/tests/web-server/dispatchers/dispatch-files-test.ss index 0212f76e73..4083255a36 100644 --- a/collects/tests/web-server/dispatchers/dispatch-files-test.ss +++ b/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) diff --git a/collects/tests/web-server/dispatchers/dispatch-host-test.ss b/collects/tests/web-server/dispatchers/dispatch-host-test.ss index c659642df9..b04c459cec 100644 --- a/collects/tests/web-server/dispatchers/dispatch-host-test.ss +++ b/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) diff --git a/collects/tests/web-server/dispatchers/dispatch-lang-test.ss b/collects/tests/web-server/dispatchers/dispatch-lang-test.ss index 2c6be0cef9..b15b37623f 100644 --- a/collects/tests/web-server/dispatchers/dispatch-lang-test.ss +++ b/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) diff --git a/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss b/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss index c1a98ab1c6..e6f633940e 100644 --- a/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss +++ b/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") diff --git a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss index e5fbba8285..9716d4b9b9 100644 --- a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss +++ b/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 diff --git a/collects/tests/web-server/dispatchers/servlet-test-util.ss b/collects/tests/web-server/dispatchers/servlet-test-util.ss index 1bc3612cfc..7b916dbdf1 100644 --- a/collects/tests/web-server/dispatchers/servlet-test-util.ss +++ b/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 diff --git a/collects/tests/web-server/private/mime-types-test.ss b/collects/tests/web-server/private/mime-types-test.ss index 632b6396bf..56ba00cbbe 100644 --- a/collects/tests/web-server/private/mime-types-test.ss +++ b/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/private/response-structs) + web-server/http + web-server/private/mime-types) (provide mime-types-tests) (define test-file (make-temporary-file)) diff --git a/collects/tests/web-server/private/request-test.ss b/collects/tests/web-server/private/request-test.ss index c97a862592..1b23697b30 100644 --- a/collects/tests/web-server/private/request-test.ss +++ b/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 diff --git a/collects/tests/web-server/private/response-test.ss b/collects/tests/web-server/private/response-test.ss index 38825d69e0..325124ec48 100644 --- a/collects/tests/web-server/private/response-test.ss +++ b/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/private/request-structs - web-server/private/response-structs + web-server/http + web-server/http/response "../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 diff --git a/collects/tests/web-server/servlet/basic-auth-test.ss b/collects/tests/web-server/servlet/basic-auth-test.ss index b01a587ed3..61679a9915 100644 --- a/collects/tests/web-server/servlet/basic-auth-test.ss +++ b/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/servlet/basic-auth) + web-server/http) (provide basic-auth-tests) (define basic-auth-tests diff --git a/collects/tests/web-server/servlet/bindings-test.ss b/collects/tests/web-server/servlet/bindings-test.ss index 0e12dab395..385ea31b47 100644 --- a/collects/tests/web-server/servlet/bindings-test.ss +++ b/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/servlet/bindings) + web-server/http + web-server/http/bindings) (provide bindings-tests) (define bs `([foo . 3] [foos . 1] [foos . 2])) diff --git a/collects/tests/web-server/servlet/helpers-test.ss b/collects/tests/web-server/servlet/helpers-test.ss index 3ac825be49..44c1428d62 100644 --- a/collects/tests/web-server/servlet/helpers-test.ss +++ b/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/private/request-structs + web-server/http web-server/servlet/helpers) (provide helpers-tests) diff --git a/collects/tests/web-server/util.ss b/collects/tests/web-server/util.ss index 82bcbaf310..9a010318d7 100644 --- a/collects/tests/web-server/util.ss +++ b/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 diff --git a/collects/web-server/configuration/configuration-table-structs.ss b/collects/web-server/configuration/configuration-table-structs.ss index 0685f648a2..552d0b1fec 100644 --- a/collects/web-server/configuration/configuration-table-structs.ss +++ b/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" - "../private/request-structs.ss" +(require web-server/http/response-structs + web-server/http/request-structs "../private/util.ss") ; configuration-table = (make-configuration-table nat nat num host-table (listof (cons str host-table))) diff --git a/collects/web-server/configuration/configuration-table.ss b/collects/web-server/configuration/configuration-table.ss index 4289e873bd..cecf293909 100644 --- a/collects/web-server/configuration/configuration-table.ss +++ b/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 diff --git a/collects/web-server/configuration/responders.ss b/collects/web-server/configuration/responders.ss index 3c5b3115a0..9e6d247552 100644 --- a/collects/web-server/configuration/responders.ss +++ b/collects/web-server/configuration/responders.ss @@ -2,8 +2,8 @@ (require mzlib/contract mzlib/list net/url) -(require "../private/response-structs.ss" - "../private/request-structs.ss") +(require web-server/http/response-structs + web-server/http/request-structs) (define (format-stack-trace trace) `(pre diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add01.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add01.ss index db066a6bc9..fdb42b0b81 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add01.ss +++ b/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) diff --git a/collects/web-server/dispatchers/dispatch-files.ss b/collects/web-server/dispatchers/dispatch-files.ss index dc5b4cd77e..ce375617ab 100644 --- a/collects/web-server/dispatchers/dispatch-files.ss +++ b/collects/web-server/dispatchers/dispatch-files.ss @@ -6,10 +6,8 @@ (require "dispatch.ss" "../private/util.ss" - "../private/request-structs.ss" - "../private/response-structs.ss" - "../servlet/helpers.ss" - "../private/response.ss" + web-server/http + web-server/http/response "../dispatchers/filesystem-map.ss") (provide/contract diff --git a/collects/web-server/dispatchers/dispatch-filter.ss b/collects/web-server/dispatchers/dispatch-filter.ss index b3c22fea16..a6c7bbed43 100644 --- a/collects/web-server/dispatchers/dispatch-filter.ss +++ b/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] diff --git a/collects/web-server/dispatchers/dispatch-host.ss b/collects/web-server/dispatchers/dispatch-host.ss index b4ee4be770..d818fac425 100644 --- a/collects/web-server/dispatchers/dispatch-host.ss +++ b/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 diff --git a/collects/web-server/dispatchers/dispatch-lift.ss b/collects/web-server/dispatchers/dispatch-lift.ss index 1da1f950a6..2d7cd621ee 100644 --- a/collects/web-server/dispatchers/dispatch-lift.ss +++ b/collects/web-server/dispatchers/dispatch-lift.ss @@ -1,9 +1,8 @@ #lang scheme/base (require mzlib/contract) (require "dispatch.ss" - "../private/response.ss" - "../private/request-structs.ss" - "../private/response-structs.ss") + web-server/http + web-server/http/response) (provide/contract [interface-version dispatcher-interface-version/c] [make ((request? . -> . response?) . -> . dispatcher/c)]) diff --git a/collects/web-server/dispatchers/dispatch-log.ss b/collects/web-server/dispatchers/dispatch-log.ss index 524cd6dd1d..adcd1ca585 100644 --- a/collects/web-server/dispatchers/dispatch-log.ss +++ b/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 diff --git a/collects/web-server/dispatchers/dispatch-passwords.ss b/collects/web-server/dispatchers/dispatch-passwords.ss index 81812954b1..6cda02c90c 100644 --- a/collects/web-server/dispatchers/dispatch-passwords.ss +++ b/collects/web-server/dispatchers/dispatch-passwords.ss @@ -5,10 +5,8 @@ (require "dispatch.ss" "../private/util.ss" "../configuration/responders.ss" - "../private/request-structs.ss" - "../private/response-structs.ss" - "../servlet/basic-auth.ss" - "../private/response.ss") + web-server/http + web-server/http/response) (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?))) diff --git a/collects/web-server/dispatchers/dispatch-pathprocedure.ss b/collects/web-server/dispatchers/dispatch-pathprocedure.ss index 1646bc66e4..97f69f62a9 100644 --- a/collects/web-server/dispatchers/dispatch-pathprocedure.ss +++ b/collects/web-server/dispatchers/dispatch-pathprocedure.ss @@ -3,9 +3,8 @@ net/url) (require "dispatch.ss" "../private/util.ss" - "../private/response.ss" - "../private/request-structs.ss" - "../private/response-structs.ss") + web-server/http + web-server/http/response) (provide/contract [interface-version dispatcher-interface-version/c] [make (string? (request? . -> . response?) . -> . dispatcher/c)]) diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index 983810fef3..cf0147436f 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/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/private/response-structs - web-server/private/request-structs + web-server/http + web-server/http/response net/url web-server/dispatchers/dispatch web-server/dispatchers/filesystem-map diff --git a/collects/web-server/dispatchers/dispatch.ss b/collects/web-server/dispatchers/dispatch.ss index ef8cddfa47..3238027a42 100644 --- a/collects/web-server/dispatchers/dispatch.ss +++ b/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)) diff --git a/collects/web-server/formlets/input.ss b/collects/web-server/formlets/input.ss index 9da96971af..4b2df7985c 100644 --- a/collects/web-server/formlets/input.ss +++ b/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) diff --git a/collects/web-server/formlets/lib.ss b/collects/web-server/formlets/lib.ss index 0af561d1af..eed6588fcc 100644 --- a/collects/web-server/formlets/lib.ss +++ b/collects/web-server/formlets/lib.ss @@ -1,5 +1,5 @@ #lang scheme -(require web-server/private/request-structs +(require web-server/http xml) ; Combinators diff --git a/collects/web-server/http.ss b/collects/web-server/http.ss new file mode 100644 index 0000000000..d7941f441b --- /dev/null +++ b/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)) \ No newline at end of file diff --git a/collects/web-server/servlet/basic-auth.ss b/collects/web-server/http/basic-auth.ss similarity index 93% rename from collects/web-server/servlet/basic-auth.ss rename to collects/web-server/http/basic-auth.ss index d2ad4f0fba..30eb983d8f 100644 --- a/collects/web-server/servlet/basic-auth.ss +++ b/collects/web-server/http/basic-auth.ss @@ -1,8 +1,8 @@ #lang scheme/base (require mzlib/contract mzlib/plt-match - net/base64) -(require "../private/request-structs.ss") + net/base64 + web-server/http/request-structs) (define (extract-user-pass headers) (match (headers-assq* #"Authorization" headers) diff --git a/collects/web-server/servlet/bindings.ss b/collects/web-server/http/bindings.ss similarity index 95% rename from collects/web-server/servlet/bindings.ss rename to collects/web-server/http/bindings.ss index 3917d3dcbb..1f40f1bc59 100644 --- a/collects/web-server/servlet/bindings.ss +++ b/collects/web-server/http/bindings.ss @@ -1,9 +1,9 @@ #lang scheme/base (require mzlib/list mzlib/contract - mzlib/plt-match) -(require "../private/util.ss" - "../private/request-structs.ss") + mzlib/plt-match + web-server/private/util + web-server/http/request-structs) (define (request-headers request) (map (match-lambda diff --git a/collects/web-server/http/redirect.ss b/collects/web-server/http/redirect.ss new file mode 100644 index 0000000000..2fede44cda --- /dev/null +++ b/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?]) diff --git a/collects/web-server/private/request-structs.ss b/collects/web-server/http/request-structs.ss similarity index 100% rename from collects/web-server/private/request-structs.ss rename to collects/web-server/http/request-structs.ss diff --git a/collects/web-server/private/request.ss b/collects/web-server/http/request.ss similarity index 98% rename from collects/web-server/private/request.ss rename to collects/web-server/http/request.ss index 02fa727449..e3f800d54f 100644 --- a/collects/web-server/private/request.ss +++ b/collects/web-server/http/request.ss @@ -3,10 +3,10 @@ mzlib/plt-match net/url mzlib/list - net/uri-codec) -(require "util.ss" - "connection-manager.ss" - "../private/request-structs.ss") + net/uri-codec + web-server/private/util + web-server/private/connection-manager + web-server/http/request-structs) (provide/contract [rename ext:read-request read-request diff --git a/collects/web-server/private/response-structs.ss b/collects/web-server/http/response-structs.ss similarity index 97% rename from collects/web-server/private/response-structs.ss rename to collects/web-server/http/response-structs.ss index 6b33641d3f..f52d32d22a 100644 --- a/collects/web-server/private/response-structs.ss +++ b/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") diff --git a/collects/web-server/private/response.ss b/collects/web-server/http/response.ss similarity index 98% rename from collects/web-server/private/response.ss rename to collects/web-server/http/response.ss index 22b115b292..53bda2d7e2 100644 --- a/collects/web-server/private/response.ss +++ b/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" - "../private/request-structs.ss" - "../private/response-structs.ss" - "util.ss") + web-server/private/connection-manager + web-server/http/request-structs + web-server/http/response-structs + 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 -;; private/request.ss +;; #t |-> 1.0 and #f |-> 1.1. See function close-connection? ;; ;; 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 diff --git a/collects/web-server/lang/lang-api.ss b/collects/web-server/lang/lang-api.ss index 94f6979549..c97d075743 100644 --- a/collects/web-server/lang/lang-api.ss +++ b/collects/web-server/lang/lang-api.ss @@ -1,8 +1,6 @@ #lang scheme (require net/url - "../private/request-structs.ss" - "../private/response-structs.ss" - "../servlet/helpers.ss" + web-server/http "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 "../private/request-structs.ss") - (all-from-out "../private/response-structs.ss") - (all-from-out "../servlet/helpers.ss") - (all-from-out "abort-resume.ss") - (all-from-out "web.ss") - (all-from-out "web-cells.ss") - (all-from-out "web-param.ss") - (all-from-out "file-box.ss") - (all-from-out "web-extras.ss")) + (all-from-out net/url + web-server/http + "abort-resume.ss" + "web.ss" + "web-cells.ss" + "web-param.ss" + "file-box.ss" + "web-extras.ss")) diff --git a/collects/web-server/lang/web-extras.ss b/collects/web-server/lang/web-extras.ss index d5eacc3f2f..1c16778323 100644 --- a/collects/web-server/lang/web-extras.ss +++ b/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 - "../servlet/helpers.ss") + web-server/http) (provide/contract [redirect/get (-> request?)]) diff --git a/collects/web-server/lang/web.ss b/collects/web-server/lang/web.ss index 5eadcc3f69..cdd9e22b62 100644 --- a/collects/web-server/lang/web.ss +++ b/collects/web-server/lang/web.ss @@ -2,11 +2,9 @@ (require net/url scheme/contract scheme/serialize - web-server/private/request-structs - web-server/private/response-structs + web-server/http web-server/private/define-closure - web-server/private/servlet - "../private/request-structs.ss" + web-server/private/servlet "abort-resume.ss" "stuff-url.ss" "../private/url-param.ss") diff --git a/collects/web-server/private/mime-types.ss b/collects/web-server/private/mime-types.ss index acdd740849..429953a88e 100644 --- a/collects/web-server/private/mime-types.ss +++ b/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?))]) diff --git a/collects/web-server/private/servlet.ss b/collects/web-server/private/servlet.ss index f35ba1c7a9..392d740b75 100644 --- a/collects/web-server/private/servlet.ss +++ b/collects/web-server/private/servlet.ss @@ -1,8 +1,7 @@ #lang scheme/base (require scheme/contract) (require "../managers/manager.ss" - "../private/request-structs.ss" - "../private/response-structs.ss") + web-server/http) (define servlet-prompt (make-continuation-prompt-tag 'servlet)) (define-struct (exn:fail:servlet:instance exn:fail) ()) diff --git a/collects/web-server/scribblings/dispatchers.scrbl b/collects/web-server/scribblings/dispatchers.scrbl index b0d62ac544..d051cf1509 100644 --- a/collects/web-server/scribblings/dispatchers.scrbl +++ b/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 - web-server/private/response-structs +@(require (for-label web-server/http net/url web-server/configuration/responders)) diff --git a/collects/web-server/scribblings/http.scrbl b/collects/web-server/scribblings/http.scrbl new file mode 100644 index 0000000000..f7cd419972 --- /dev/null +++ b/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 #"

" + #"Please go to here instead." + #"

")) + ] +} + +@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")]. +} diff --git a/collects/web-server/scribblings/servlet.scrbl b/collects/web-server/scribblings/servlet.scrbl index 1d9ffc81b4..74f6beb06c 100644 --- a/collects/web-server/scribblings/servlet.scrbl +++ b/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 #"

" - #"Please go to here instead." - #"

")) - ] -} - -@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)) diff --git a/collects/web-server/scribblings/web-server.scrbl b/collects/web-server/scribblings/web-server.scrbl index 8599fc3ae8..2fd884ee87 100644 --- a/collects/web-server/scribblings/web-server.scrbl +++ b/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"] diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index f90e644a2e..d9b90ecc61 100644 --- a/collects/web-server/servlet-env.ss +++ b/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/private/response-structs + web-server/http web-server/private/util web-server/configuration/responders web-server/dispatchers/dispatch diff --git a/collects/web-server/servlet.ss b/collects/web-server/servlet.ss index fbadcdc99f..7618766551 100644 --- a/collects/web-server/servlet.ss +++ b/collects/web-server/servlet.ss @@ -1,17 +1,13 @@ #lang scheme/base -(require "servlet/helpers.ss" - "servlet/web-cells.ss" - "servlet/bindings.ss" - "servlet/basic-auth.ss" - "servlet/web.ss" - "servlet/servlet-structs.ss" - "private/response-structs.ss" - "private/request-structs.ss") -(provide (all-from-out "servlet/web.ss") - (all-from-out "servlet/web-cells.ss") - (all-from-out "servlet/helpers.ss") - (all-from-out "servlet/bindings.ss") - (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")) +(require web-server/servlet/helpers + web-server/servlet/web-cells + web-server/http/bindings + web-server/http + web-server/servlet/servlet-structs + web-server/servlet/web) +(provide (all-from-out web-server/servlet/helpers + web-server/servlet/web-cells + web-server/http/bindings + web-server/http + web-server/servlet/servlet-structs + web-server/servlet/web)) \ No newline at end of file diff --git a/collects/web-server/servlet/helpers.ss b/collects/web-server/servlet/helpers.ss index d6e605b61a..1d3c3aea88 100644 --- a/collects/web-server/servlet/helpers.ss +++ b/collects/web-server/servlet/helpers.ss @@ -1,27 +1,7 @@ #lang scheme/base (require scheme/contract) (require "../private/util.ss" - "../private/request-structs.ss" - "../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))) + web-server/http) (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) diff --git a/collects/web-server/servlet/servlet-structs.ss b/collects/web-server/servlet/servlet-structs.ss index eb5e58f241..92794e95f7 100644 --- a/collects/web-server/servlet/servlet-structs.ss +++ b/collects/web-server/servlet/servlet-structs.ss @@ -1,7 +1,6 @@ #lang scheme/base -(require scheme/contract) -(require "../private/request-structs.ss" - "../private/response-structs.ss") +(require scheme/contract + web-server/http) (define k-url? string?) diff --git a/collects/web-server/servlet/setup.ss b/collects/web-server/servlet/setup.ss index 93a1401803..2cecb0b0d5 100644 --- a/collects/web-server/servlet/setup.ss +++ b/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/private/request-structs + web-server/http 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/private/response-structs)) + web-server/http)) (define servlet-module-specs '(web-server/servlet/web diff --git a/collects/web-server/servlet/web.ss b/collects/web-server/servlet/web.ss index ccb8d92db4..20c37fe17f 100644 --- a/collects/web-server/servlet/web.ss +++ b/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" - "../private/request-structs.ss") + web-server/http) (provide servlet-prompt) diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index 1d1547f052..44dd44198b 100644 --- a/collects/web-server/web-server-unit.ss +++ b/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") diff --git a/collects/web-server/web-server.ss b/collects/web-server/web-server.ss index 666992e137..3a293ad793 100644 --- a/collects/web-server/web-server.ss +++ b/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)