diff --git a/collects/tests/web-server/dispatchers/dispatch-lang-test.ss b/collects/tests/web-server/dispatchers/dispatch-lang-test.ss index 0a12cc6ccc..2c6be0cef9 100644 --- a/collects/tests/web-server/dispatchers/dispatch-lang-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-lang-test.ss @@ -6,7 +6,7 @@ web-server/dispatchers/dispatch web-server/private/request-structs web-server/configuration/namespace - #;(prefix-in lang: web-server/dispatchers/dispatch-lang) + web-server/servlet/setup (prefix-in servlets: web-server/dispatchers/dispatch-servlets) "servlet-test-util.ss" "../util.ss") @@ -29,7 +29,7 @@ (define-values (! u->s) (servlets:make-cached-url->servlet (lambda _ (values p url0s)) - (servlets:make-default-path->servlet))) + (make-default-path->servlet))) (define d (servlets:make u->s #:responders-servlet-loading diff --git a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss index 7438df0635..6760cbf2d3 100644 --- a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss @@ -7,6 +7,7 @@ web-server/private/cache-table web-server/private/web-server-structs web-server/configuration/namespace + web-server/servlet/setup (prefix-in servlets: web-server/dispatchers/dispatch-servlets) "servlet-test-util.ss" "../util.ss") @@ -18,7 +19,7 @@ (define-values (! u->s) (servlets:make-cached-url->servlet (lambda _ (values p url0s)) - (servlets:make-default-path->servlet))) + (make-default-path->servlet))) (define d (servlets:make u->s #:responders-servlet-loading diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index 43fc442604..983810fef3 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -1,151 +1,22 @@ #lang scheme/base -(require mzlib/plt-match - scheme/contract) -(require "dispatch.ss" - "../private/web-server-structs.ss" - "../private/connection-manager.ss" - web-server/managers/none - (only-in "../lang/web.ss" - initialize-servlet) - "../private/response.ss" - "../private/request-structs.ss" - "../private/response-structs.ss" - "../servlet/web-cells.ss" - "../servlet/web.ss" +(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 net/url - "../dispatchers/filesystem-map.ss" - "../configuration/responders.ss" - "../configuration/namespace.ss" - "../managers/manager.ss" - "../managers/timeouts.ss" - (except-in "../private/servlet.ss" - servlet-prompt) - "../private/cache-table.ss" - "../private/util.ss") + web-server/dispatchers/dispatch + web-server/dispatchers/filesystem-map + web-server/configuration/responders + web-server/private/connection-manager + web-server/private/web-server-structs + web-server/private/servlet + web-server/private/cache-table) (provide/contract [interface-version dispatcher-interface-version/c]) (define interface-version 'v1) -; ----- -(define path->servlet/c (path? . -> . servlet?)) -(provide/contract - [path->servlet/c contract?] - [make-default-path->servlet - (->* () - (#:make-servlet-namespace make-servlet-namespace/c - #:timeouts-default-servlet number?) - path->servlet/c)]) - -(define (v0.response->v1.lambda response response-path) - (define go - (box - (lambda () - (set-box! go (lambda () (load/use-compiled response-path))) - response))) - (lambda (initial-request) - ((unbox go)))) - -(define (make-v1.servlet directory timeout start) - (make-v2.servlet - directory - (create-timeout-manager - default-servlet-instance-expiration-handler - timeout - timeout) - (lambda (initial-request) - (adjust-timeout! timeout) - (start initial-request)))) - -(define (make-v2.servlet directory manager start) - (make-servlet - (current-custodian) - (current-namespace) - manager - directory - (lambda (req) - (define uri (request-uri req)) - - (define-values (instance-id handler) - (cond - [(continuation-url? uri) - => (match-lambda - [(list instance-id k-id salt) - (values instance-id - (custodian-box-value ((manager-continuation-lookup manager) instance-id k-id salt)))])] - [else - (values ((manager-create-instance manager) (exit-handler)) - start)])) - - (parameterize ([current-servlet-instance-id instance-id]) - (handler req))))) - -(define (make-stateless.servlet directory start) - (define ses - (make-servlet - (current-custodian) (current-namespace) - (create-none-manager (lambda (req) (error "No continuations!"))) - directory - (lambda (req) (error "Session not initialized")))) - (parameterize ([current-directory directory] - [current-servlet ses]) - (set-servlet-handler! ses (initialize-servlet start))) - ses) - -(define common-module-specs - '(web-server/private/servlet - web-server/private/request-structs - web-server/private/response-structs)) - -(define servlet-module-specs - '(web-server/servlet/web - web-server/servlet/web-cells)) -(define lang-module-specs - '(web-server/lang/web-cells - web-server/lang/abort-resume)) -(define default-module-specs - (append common-module-specs - servlet-module-specs - lang-module-specs)) -(provide/contract - [make-v1.servlet (path? integer? (request? . -> . response?) . -> . servlet?)] - [make-v2.servlet (path? manager? (request? . -> . response?) . -> . servlet?)] - [make-stateless.servlet (path? (request? . -> . response?) . -> . servlet?)] - [default-module-specs (listof module-path?)]) - -(define (make-default-path->servlet #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)] - #:timeouts-default-servlet [timeouts-default-servlet 30]) - (lambda (a-path) - (parameterize ([current-namespace (make-servlet-namespace - #:additional-specs - default-module-specs)] - [current-custodian (make-servlet-custodian)]) - (define s (load/use-compiled a-path)) - (cond - [(void? s) - (let* ([module-name `(file ,(path->string a-path))] - [version (dynamic-require module-name 'interface-version)]) - (case version - [(v1) - (let ([timeout (dynamic-require module-name 'timeout)] - [start (dynamic-require module-name 'start)]) - (make-v1.servlet (directory-part a-path) timeout start))] - [(v2) - (let ([start (dynamic-require module-name 'start)] - [manager (dynamic-require module-name 'manager)]) - (make-v2.servlet (directory-part a-path) manager start))] - [(stateless) - (let ([start (dynamic-require module-name 'start)]) - (make-stateless.servlet (directory-part a-path) start))] - [else - (error 'path->servlet "unknown servlet version ~e, must be 'v1, 'v2, or 'stateless" version)]))] - [(response? s) - (make-v1.servlet (directory-part a-path) timeouts-default-servlet - (v0.response->v1.lambda s a-path))] - [else - (error 'path->servlet - "Loading ~e produced ~n~e~n instead of either (1) a response or (2) nothing and exports 'interface-version" a-path s)])))) - -; ----- (define url->servlet/c (url? . -> . servlet?)) (provide/contract [url->servlet/c contract?] diff --git a/collects/web-server/run.ss b/collects/web-server/run.ss deleted file mode 100644 index cfda21691b..0000000000 --- a/collects/web-server/run.ss +++ /dev/null @@ -1,72 +0,0 @@ -#lang scheme/base -; This file is intended to be copied and/or modified and used as a template. -(require mzlib/cmdline - (only-in mzlib/file - normalize-path) - web-server/web-server - web-server/configuration/responders - web-server/private/mime-types - (prefix-in path-procedure: "dispatchers/dispatch-pathprocedure.ss") - (prefix-in fsmap: web-server/dispatchers/filesystem-map) - (prefix-in timeout: web-server/dispatchers/dispatch-timeout) - (prefix-in files: web-server/dispatchers/dispatch-files) - (prefix-in filter: web-server/dispatchers/dispatch-filter) - (prefix-in lift: web-server/dispatchers/dispatch-lift) - (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer) - (prefix-in servlets: web-server/dispatchers/dispatch-servlets) - (prefix-in stat: web-server/dispatchers/dispatch-stat)) - -(define server-root-path (make-parameter (collection-path "web-server" "default-web-root"))) -(define port (make-parameter 8080)) - -(parse-command-line - "run" (current-command-line-arguments) - `((once-each - [("-p" "--port") - ,(lambda (flag the-port) (port (string->number the-port))) - (,(format "Specify a different port (default: ~a)" (number->string (port))) - "number")] - [("-r" "--root") - ,(lambda (flag path) (server-root-path (normalize-path (string->path path)))) - (,(format "Specify a different server root path (default: ~a)" (path->string (server-root-path))) - "path")])) - (lambda (flag-accum) (void)) - null) - -(define default-host-path (build-path (server-root-path) "conf")) -(define file-not-found-file (build-path default-host-path "not-found.html")) -(define servlet-error-file (build-path default-host-path "servlet-error.html")) -(define servlet-refresh-file (build-path default-host-path "servlet-refresh.html")) - -(define url->path - (fsmap:make-url->path - (build-path (server-root-path) "htdocs"))) - -(define gc-thread (stat:make-gc-thread 30)) - -(serve #:port (port) - #:dispatch - (sequencer:make - (timeout:make (* 5 60)) - (stat:make) - (let-values ([(clear-cache! url->servlet) - (servlets:make-cached-url->servlet - (fsmap:filter-url->path - #rx"\\.(ss|scm)$" - (fsmap:make-url->valid-path - url->path)) - (servlets:make-default-path->servlet))]) - (sequencer:make - (path-procedure:make "/conf/refresh-servlets" - (lambda _ - (clear-cache!) - ((gen-servlets-refreshed servlet-refresh-file)))) - (servlets:make url->servlet - #:responders-servlet-loading (gen-servlet-responder servlet-error-file) - #:responders-servlet (gen-servlet-responder servlet-error-file)))) - (files:make #:url->path url->path - #:path->mime-type (make-path->mime-type (build-path (server-root-path) "mime.types")) - #:indices (list "index.html" "index.htm")) - (lift:make (gen-file-not-found-responder file-not-found-file)))) - -(do-not-return) diff --git a/collects/web-server/scribblings/dispatchers.scrbl b/collects/web-server/scribblings/dispatchers.scrbl index c4fe8c6aa7..b0d62ac544 100644 --- a/collects/web-server/scribblings/dispatchers.scrbl +++ b/collects/web-server/scribblings/dispatchers.scrbl @@ -332,48 +332,6 @@ a URL that refreshes the password file, servlet cache, etc.} @a-dispatcher[web-server/dispatchers/dispatch-servlets @elem{defines a dispatcher constructor that runs servlets.}]{ - -@defproc[(make-v1.servlet [directory path?] - [timeout integer?] - [start (request? . -> . response?)]) - servlet?]{ - Creates a version 1 servlet that uses @scheme[directory] as its current directory, a timeout manager with a @scheme[timeout] timeout, and @scheme[start] as the request handler. -} - -@defproc[(make-v2.servlet [directory path?] - [manager manager?] - [start (request? . -> . response?)]) - servlet?]{ - Creates a version 2 servlet that uses @scheme[directory] as its current directory, a @scheme[manager] as the continuation manager, and @scheme[start] as the request handler. -} - -@defproc[(make-stateless.servlet [directory path?] - [start (request? . -> . response?)]) - servlet?]{ - Creates a stateless @schememodname[web-server] servlet that uses @scheme[directory] as its current directory and @scheme[start] as the request handler. -} - -@defthing[default-module-specs (listof module-path?)]{ - The modules that the Web Server needs to share with all servlets. -} - -@defthing[path->servlet/c contract?]{ -Equivalent to @scheme[(path? . -> . servlet?)]. -} - -@defproc[(make-default-path->servlet - [#:make-servlet-namespace - make-servlet-namespace - make-servlet-namespace? - (make-make-servlet-namespace)] - [#:timeouts-default-servlet - timeouts-default-servlet - integer? - 30]) - path->servlet/c]{ - Constructs a procedure that loads a servlet from the path in a namespace created with @scheme[make-servlet-namespace], - using a timeout manager with @scheme[timeouts-default-servlet] as the default timeout (if no manager is given.) -} @defthing[url->servlet/c contract?]{Equivalent to @scheme[(url? . -> . servlet?)]} diff --git a/collects/web-server/scribblings/running.scrbl b/collects/web-server/scribblings/running.scrbl index 1d4ec5bd84..7c567b7ca4 100644 --- a/collects/web-server/scribblings/running.scrbl +++ b/collects/web-server/scribblings/running.scrbl @@ -82,7 +82,7 @@ To run the web server with MrEd, use @filepath{web-server.ss} provides a number of functions for easing embedding of the @web-server in other applications, or loading a custom -dispatcher. See @filepath{run.ss} for an example of such a script. +dispatcher. @defproc[(serve [#:dispatch dispatch dispatcher?] [#:tcp@ tcp@ tcp-unit^ raw:tcp@] diff --git a/collects/web-server/scribblings/servlet.scrbl b/collects/web-server/scribblings/servlet.scrbl index b065603d4d..93183d99bd 100644 --- a/collects/web-server/scribblings/servlet.scrbl +++ b/collects/web-server/scribblings/servlet.scrbl @@ -673,3 +673,53 @@ transformations of the program into continuation or store passing style. (loop)))]) "+"))))))) ] + +@; ------------------------------------------------------------ +@section[#:tag "setup.ss"]{Setup} +@(require (for-label web-server/servlet/setup)) + +@defmodule[web-server/servlet/setup] + +This module is used internally to build and load servlets. It may be useful to those who are trying to extend the server. + +@defproc[(make-v1.servlet [directory path?] + [timeout integer?] + [start (request? . -> . response?)]) + servlet?]{ + Creates a version 1 servlet that uses @scheme[directory] as its current directory, a timeout manager with a @scheme[timeout] timeout, and @scheme[start] as the request handler. +} + +@defproc[(make-v2.servlet [directory path?] + [manager manager?] + [start (request? . -> . response?)]) + servlet?]{ + Creates a version 2 servlet that uses @scheme[directory] as its current directory, a @scheme[manager] as the continuation manager, and @scheme[start] as the request handler. +} + +@defproc[(make-stateless.servlet [directory path?] + [start (request? . -> . response?)]) + servlet?]{ + Creates a stateless @schememodname[web-server] servlet that uses @scheme[directory] as its current directory and @scheme[start] as the request handler. +} + +@defthing[default-module-specs (listof module-path?)]{ + The modules that the Web Server needs to share with all servlets. +} + +@defthing[path->servlet/c contract?]{ +Equivalent to @scheme[(path? . -> . servlet?)]. +} + +@defproc[(make-default-path->servlet + [#:make-servlet-namespace + make-servlet-namespace + make-servlet-namespace? + (make-make-servlet-namespace)] + [#:timeouts-default-servlet + timeouts-default-servlet + integer? + 30]) + path->servlet/c]{ + Constructs a procedure that loads a servlet from the path in a namespace created with @scheme[make-servlet-namespace], + using a timeout manager with @scheme[timeouts-default-servlet] as the default timeout (if no manager is given.) +} \ No newline at end of file diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index 3d9305aacc..f90e644a2e 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -17,6 +17,7 @@ web-server/dispatchers/dispatch web-server/private/mime-types web-server/configuration/configuration-table + web-server/servlet/setup (prefix-in lift: web-server/dispatchers/dispatch-lift) (prefix-in fsmap: web-server/dispatchers/filesystem-map) (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer) @@ -121,10 +122,10 @@ [current-namespace (make-servlet-namespace #:additional-specs - servlets:default-module-specs)]) + default-module-specs)]) (if stateless? - (servlets:make-stateless.servlet servlet-current-directory start) - (servlets:make-v2.servlet servlet-current-directory manager start)))]) + (make-stateless.servlet servlet-current-directory start) + (make-v2.servlet servlet-current-directory manager start)))]) (set-box! servlet-box servlet) servlet))))) (let-values ([(clear-cache! url->servlet) @@ -133,7 +134,7 @@ #rx"\\.(ss|scm)$" (fsmap:make-url->valid-path (fsmap:make-url->path servlets-root))) - (servlets:make-default-path->servlet + (make-default-path->servlet #:make-servlet-namespace make-servlet-namespace))]) (servlets:make url->servlet)) (apply sequencer:make diff --git a/collects/web-server/servlet/setup.ss b/collects/web-server/servlet/setup.ss new file mode 100644 index 0000000000..93a1401803 --- /dev/null +++ b/collects/web-server/servlet/setup.ss @@ -0,0 +1,131 @@ +#lang scheme/base +(require mzlib/plt-match + scheme/contract) +(require web-server/managers/manager + web-server/managers/timeouts + web-server/managers/none + (only-in web-server/lang/web + initialize-servlet) + web-server/private/response-structs + web-server/private/request-structs + web-server/servlet/web + web-server/configuration/namespace + web-server/private/web-server-structs + web-server/private/servlet + web-server/private/util) + +(define path->servlet/c (path? . -> . servlet?)) +(provide/contract + [path->servlet/c contract?] + [make-default-path->servlet + (->* () + (#:make-servlet-namespace make-servlet-namespace/c + #:timeouts-default-servlet number?) + path->servlet/c)]) + +(define (v0.response->v1.lambda response response-path) + (define go + (box + (lambda () + (set-box! go (lambda () (load/use-compiled response-path))) + response))) + (lambda (initial-request) + ((unbox go)))) + +(define (make-v1.servlet directory timeout start) + (make-v2.servlet + directory + (create-timeout-manager + #f timeout timeout) + (lambda (initial-request) + (adjust-timeout! timeout) + (start initial-request)))) + +(define (make-v2.servlet directory manager start) + (make-servlet + (current-custodian) + (current-namespace) + manager + directory + (lambda (req) + (define uri (request-uri req)) + + (define-values (instance-id handler) + (cond + [(continuation-url? uri) + => (match-lambda + [(list instance-id k-id salt) + (values instance-id + (custodian-box-value ((manager-continuation-lookup manager) instance-id k-id salt)))])] + [else + (values ((manager-create-instance manager) (exit-handler)) + start)])) + + (parameterize ([current-servlet-instance-id instance-id]) + (handler req))))) + +(define (make-stateless.servlet directory start) + (define ses + (make-servlet + (current-custodian) (current-namespace) + (create-none-manager (lambda (req) (error "No continuations!"))) + directory + (lambda (req) (error "Session not initialized")))) + (parameterize ([current-directory directory] + [current-servlet ses]) + (set-servlet-handler! ses (initialize-servlet start))) + ses) + +(define common-module-specs + '(web-server/private/servlet + web-server/private/request-structs + web-server/private/response-structs)) + +(define servlet-module-specs + '(web-server/servlet/web + web-server/servlet/web-cells)) +(define lang-module-specs + '(web-server/lang/web-cells + web-server/lang/abort-resume)) +(define default-module-specs + (append common-module-specs + servlet-module-specs + lang-module-specs)) +(provide/contract + [make-v1.servlet (path? integer? (request? . -> . response?) . -> . servlet?)] + [make-v2.servlet (path? manager? (request? . -> . response?) . -> . servlet?)] + [make-stateless.servlet (path? (request? . -> . response?) . -> . servlet?)] + [default-module-specs (listof module-path?)]) + +(define (make-default-path->servlet #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)] + #:timeouts-default-servlet [timeouts-default-servlet 30]) + (lambda (a-path) + (parameterize ([current-namespace (make-servlet-namespace + #:additional-specs + default-module-specs)] + [current-custodian (make-servlet-custodian)]) + (define s (load/use-compiled a-path)) + (cond + [(void? s) + (let* ([module-name `(file ,(path->string a-path))] + [version (dynamic-require module-name 'interface-version)]) + (case version + [(v1) + (let ([timeout (dynamic-require module-name 'timeout)] + [start (dynamic-require module-name 'start)]) + (make-v1.servlet (directory-part a-path) timeout start))] + [(v2) + (let ([start (dynamic-require module-name 'start)] + [manager (dynamic-require module-name 'manager)]) + (make-v2.servlet (directory-part a-path) manager start))] + [(stateless) + (let ([start (dynamic-require module-name 'start)]) + (make-stateless.servlet (directory-part a-path) start))] + [else + (error 'path->servlet "unknown servlet version ~e, must be 'v1, 'v2, or 'stateless" version)]))] + [(response? s) + (make-v1.servlet (directory-part a-path) timeouts-default-servlet + (v0.response->v1.lambda s a-path))] + [else + (error 'path->servlet + "Loading ~e produced ~n~e~n instead of either (1) a response or (2) nothing and exports 'interface-version" a-path s)])))) \ No newline at end of file diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index b2e67cf1cf..1d1547f052 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -11,6 +11,7 @@ "private/cache-table.ss" (prefix-in http: "private/request.ss")) (require "dispatchers/dispatch.ss" + web-server/servlet/setup (prefix-in fsmap: "dispatchers/filesystem-map.ss") (prefix-in sequencer: "dispatchers/dispatch-sequencer.ss") (prefix-in timeout: web-server/dispatchers/dispatch-timeout) @@ -81,7 +82,7 @@ #rx"\\.(ss|scm)$" (fsmap:make-url->valid-path (fsmap:make-url->path (paths-servlet (host-paths host-info))))) - (servlets:make-default-path->servlet + (make-default-path->servlet #:make-servlet-namespace config:make-servlet-namespace #:timeouts-default-servlet (timeouts-default-servlet (host-timeouts host-info))))]) (sequencer:make