From 9e20ad7c466b3f9a0f53ebeccd66c1e83ab1a085 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 14 Aug 2008 19:45:35 +0000 Subject: [PATCH] In response to the tutorial thread, I've merge in plai/web and instaservlet into the main repository. web-server/servlet-env can now provide most of the instaservlet functionality. web-server/insta provides the functionality of plai/web, inconcert with web-server/servlet-env. managers/lru is more useful with a default threshold-based manager. The default error handling is that of plai/web. svn: r11246 --- .../web-server/configuration/responders.ss | 51 ++++- .../default-web-root/htdocs/error.css | 25 +++ .../web-server/dispatchers/dispatch-lang.ss | 2 +- .../dispatchers/dispatch-servlets.ss | 2 +- collects/web-server/insta/insta.ss | 38 ++++ collects/web-server/insta/lang/reader.ss | 2 + collects/web-server/managers/lru.ss | 30 ++- .../scribblings/configuration.scrbl | 10 +- .../web-server/scribblings/dispatchers.scrbl | 14 +- collects/web-server/scribblings/lang.scrbl | 4 + .../web-server/scribblings/managers.scrbl | 28 +-- collects/web-server/scribblings/running.scrbl | 44 ++++- .../web-server/scribblings/servlet-env.scrbl | 62 +++++-- collects/web-server/scribblings/servlet.scrbl | 6 +- .../web-server/scribblings/web-server.scrbl | 7 +- collects/web-server/servlet-env.ss | 174 +++++++++++------- collects/web-server/tests/servlet-env-test.ss | 16 +- collects/web-server/web-config-unit.ss | 2 +- 18 files changed, 381 insertions(+), 136 deletions(-) create mode 100644 collects/web-server/default-web-root/htdocs/error.css create mode 100644 collects/web-server/insta/insta.ss create mode 100644 collects/web-server/insta/lang/reader.ss diff --git a/collects/web-server/configuration/responders.ss b/collects/web-server/configuration/responders.ss index 3b3e878e4f..3c5b3115a0 100644 --- a/collects/web-server/configuration/responders.ss +++ b/collects/web-server/configuration/responders.ss @@ -5,6 +5,37 @@ (require "../private/response-structs.ss" "../private/request-structs.ss") +(define (format-stack-trace trace) + `(pre + ,@(for/list ([item (in-list trace)]) + (format "~a at:~n ~a~n" + (if (car item) + (car item) + "") + (if (cdr item) + (format "line ~a, column ~a, in file ~a" + (srcloc-line (cdr item)) + (srcloc-column (cdr item)) + (srcloc-source (cdr item))) + ""))))) + +(define (pretty-exception-response url exn) + `(html + (head + (title "Servlet Error") + (link ([rel "stylesheet"] [href "/error.css"]))) + (body + (div ([class "section"]) + (div ([class "title"]) "Exception") + (p + "The application raised an exception with the message:" + (pre ,(exn-message exn))) + (p + "Stack trace:" + ,(format-stack-trace + (continuation-mark-set->context (exn-continuation-marks exn)))))))) + + ; file-response : nat str str [(cons sym str) ...] -> response ; The server should still start without the files there, so the ; configuration tool still runs. (Alternatively, find an work around.) @@ -18,19 +49,22 @@ ; This is slightly tricky since the (interesting) content comes from the exception. (define (servlet-loading-responder url exn) ((error-display-handler) - (format "Servlet didn't load:\n~a\n" (exn-message exn)) + (format "Servlet (@ ~a) didn't load:\n~a\n" (url->string url) (exn-message exn)) exn) - (make-response/full 500 "Servlet didn't load" - (current-seconds) - TEXT/HTML-MIME-TYPE - empty - (list "Servlet didn't load.\n"))) + (pretty-exception-response url exn)) ; gen-servlet-not-found : str -> url -> response (define (gen-servlet-not-found file-not-found-file) (lambda (url) (file-response 404 "Servlet not found" file-not-found-file))) +; servlet-error-response : url exn -> response +(define (servlet-error-responder url exn) + ((error-display-handler) + (format "Servlet (@ ~a) exception:\n~a\n" (url->string url) (exn-message exn)) + exn) + (pretty-exception-response url exn)) + ; gen-servlet-responder : str -> url tst -> response (define (gen-servlet-responder servlet-error-file) (lambda (url exn) @@ -77,9 +111,10 @@ (provide/contract [file-response ((natural-number/c string? path-string?) (listof header?) . ->* . (response?))] - [servlet-loading-responder (url? any/c . -> . response?)] + [servlet-loading-responder (url? exn? . -> . response?)] [gen-servlet-not-found (path-string? . -> . (url? . -> . response?))] - [gen-servlet-responder (path-string? . -> . (url? any/c . -> . response?))] + [servlet-error-responder (url? exn? . -> . response?)] + [gen-servlet-responder (path-string? . -> . (url? exn? . -> . response?))] [gen-servlets-refreshed (path-string? . -> . (-> response?))] [gen-passwords-refreshed (path-string? . -> . (-> response?))] [gen-authentication-responder (path-string? . -> . (url? header? . -> . response?))] diff --git a/collects/web-server/default-web-root/htdocs/error.css b/collects/web-server/default-web-root/htdocs/error.css new file mode 100644 index 0000000000..ec070d0f82 --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/error.css @@ -0,0 +1,25 @@ +.section { + margin: 25px; + font-family: sans-serif; + border: 1px solid black; +} + +.title { + background-color: #663366; + font-size: large; + padding: 5px; + color: #FFFFFF; +} + +.section > p { + margin-left: 5px; + margin-right: 5px; +} + +.section > pre { + background-color: #ffccff; + margin-left: 5px; + margin-right: 5px; + padding: 5px; + border: 1px solid #ff99ff; +} diff --git a/collects/web-server/dispatchers/dispatch-lang.ss b/collects/web-server/dispatchers/dispatch-lang.ss index 67c6fd9b3e..5ca6f78dc8 100644 --- a/collects/web-server/dispatchers/dispatch-lang.ss +++ b/collects/web-server/dispatchers/dispatch-lang.ss @@ -31,7 +31,7 @@ (define (make #:url->path url->path #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)] #:responders-servlet-loading [responders-servlet-loading servlet-loading-responder] - #:responders-servlet [responders-servlet (gen-servlet-responder "servlet-error.html")]) + #:responders-servlet [responders-servlet servlet-error-responder]) ;; dispatch : connection request -> void (define (dispatch conn req) diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index 880c8b20a2..eefeeedf4f 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -34,7 +34,7 @@ #:url->path url->path #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)] #:responders-servlet-loading [responders-servlet-loading servlet-loading-responder] - #:responders-servlet [responders-servlet (gen-servlet-responder "servlet-error.html")] + #:responders-servlet [responders-servlet servlet-error-responder] #:timeouts-default-servlet [timeouts-default-servlet 30]) ;; servlet-content-producer: connection request -> void diff --git a/collects/web-server/insta/insta.ss b/collects/web-server/insta/insta.ss new file mode 100644 index 0000000000..2ac0755800 --- /dev/null +++ b/collects/web-server/insta/insta.ss @@ -0,0 +1,38 @@ +#lang scheme +(require web-server/servlet + web-server/servlet-env) + +(provide + (all-from-out web-server/servlet) + (except-out (all-from-out scheme) #%module-begin) + (rename-out [web-module-begin #%module-begin])) + +(define extra-files-path #f) +(define launch-browser? #t) + +(provide/contract + (static-files-path ((or/c string? path?) . -> . void?))) +(define (static-files-path path) + (set! extra-files-path + (if (path? path) + path + (string->path path)))) + +(provide no-web-browser) +(define (no-web-browser) + (set! launch-browser? false)) + +(define-syntax (web-module-begin stx) + (syntax-case stx () + [(_ body ...) + (with-syntax ([start (datum->syntax stx 'start)]) + #`(#%module-begin + body ... + (provide/contract (start (request? . -> . response?))) + (if extra-files-path + (serve/servlet start + #:extra-files-path extra-files-path + #:launch-browser? launch-browser?) + (serve/servlet start + #:launch-browser? launch-browser?)) + ))])) \ No newline at end of file diff --git a/collects/web-server/insta/lang/reader.ss b/collects/web-server/insta/lang/reader.ss new file mode 100644 index 0000000000..0a333dfe9c --- /dev/null +++ b/collects/web-server/insta/lang/reader.ss @@ -0,0 +1,2 @@ +(module reader syntax/module-reader + web-server/insta/insta) diff --git a/collects/web-server/managers/lru.ss b/collects/web-server/managers/lru.ss index 1be5b38e6c..8850c45b11 100644 --- a/collects/web-server/managers/lru.ss +++ b/collects/web-server/managers/lru.ss @@ -5,9 +5,10 @@ "../servlet/servlet-structs.ss") (provide/contract [create-LRU-manager (expiration-handler? number? number? (-> boolean?) - #:initial-count number? - #:inform-p (number? . -> . void) - . -> . manager?)]) + #:initial-count number? + #:inform-p (number? . -> . void) + . -> . manager?)] + [make-threshold-LRU-manager (expiration-handler? number? . -> . manager?)]) ;; Utility (define (make-counter) @@ -16,6 +17,29 @@ (set! i (add1 i)) i)) +; Copied from InstaServlet, which copied from Continue (I believe?) +(define (make-threshold-LRU-manager instance-expiration-handler + memory-threshold) + (create-LRU-manager + ;; Called when an instance has expired. + instance-expiration-handler + ;; The condition below is checked every 5 seconds + 5 + ;; One 'life point' is deducted every 10 minutes + (* 10 60) + ;; If this condition is true a 'life point' is deducted + ;; from the continuation + (lambda () + (define memory-use (current-memory-use)) + (define collect? (or (>= memory-use memory-threshold) + (< memory-use 0))) + collect?) + ;; The number of 'life points' an continuation starts with + #:initial-count 24 + ;; Logging done whenever an continuation is collected + #:inform-p (lambda args + (void)))) + (define-struct (LRU-manager manager) (instance-expiration-handler ; Private instances diff --git a/collects/web-server/scribblings/configuration.scrbl b/collects/web-server/scribblings/configuration.scrbl index 94b8fdf07b..76090f3cd3 100644 --- a/collects/web-server/scribblings/configuration.scrbl +++ b/collects/web-server/scribblings/configuration.scrbl @@ -212,10 +212,9 @@ as the corresponding fields; with the content of the @scheme[text-file] as the b the @scheme[header]s as, you guessed it, headers. } -@defproc[(servlet-loading-responder (url url?) (exn any/c)) +@defproc[(servlet-loading-responder (url url?) (exn exn?)) response?]{ - Prints the @scheme[exn] to standard output and responds with a "Servlet didn't load." -message. + Gives @scheme[exn] to the @scheme[current-error-handler] and response with a stack trace and a "Servlet didn't load" message. } @defproc[(gen-servlet-not-found (file path-string?)) @@ -223,6 +222,11 @@ message. Returns a function that generates a standard "Servlet not found." error with content from @scheme[file]. } +@defproc[(servlet-error-responder (url url?) (exn exn?)) + response?]{ + Gives @scheme[exn] to the @scheme[current-error-handler] and response with a stack trace and a "Servlet error" message. +} + @defproc[(gen-servlet-responder (file path-string?)) ((url url?) (exn any/c) . -> . response?)]{ Prints the @scheme[exn] to standard output and responds with a "Servlet error." message with content from @scheme[file]. diff --git a/collects/web-server/scribblings/dispatchers.scrbl b/collects/web-server/scribblings/dispatchers.scrbl index 319a46342b..f4c14d8083 100644 --- a/collects/web-server/scribblings/dispatchers.scrbl +++ b/collects/web-server/scribblings/dispatchers.scrbl @@ -311,12 +311,12 @@ a URL that refreshes the password file, servlet cache, etc.} (make-make-servlet-namespace)] [#:responders-servlet-loading responders-servlet-loading - ((url url?) (exn any/c) . -> . response?) + ((url url?) (exn exn?) . -> . response?) servlet-loading-responder] [#:responders-servlet responders-servlet - ((url url?) (exn any/c) . -> . response?) - (gen-servlet-responder "servlet-error.html")] + ((url url?) (exn exn?) . -> . response?) + servlet-error-responder] [#:timeouts-default-servlet timeouts-default-servlet integer? @@ -348,8 +348,12 @@ a URL that refreshes the password file, servlet cache, etc.} [#:make-servlet-namespace make-servlet-namespace make-servlet-namespace? (make-make-servlet-namespace)] - [#:responders-servlet-loading responders-servlet-loading servlet-loading-responder] - [#:responders-servlet responders-servlet (gen-servlet-responder "servlet-error.html")]) + [#:responders-servlet-loading responders-servlet-loading + ((url url?) (exn exn?) . -> . response?) + servlet-loading-responder] + [#:responders-servlet responders-servlet + ((url url?) (exn exn?) . -> . response?) + servlet-error-responder]) dispatcher?]{ If the request URL contains a serialized continuation, then it is invoked with the request. Otherwise, @scheme[url->path] is used to resolve the URL to a path. diff --git a/collects/web-server/scribblings/lang.scrbl b/collects/web-server/scribblings/lang.scrbl index 69fa313d69..8df821d0ea 100644 --- a/collects/web-server/scribblings/lang.scrbl +++ b/collects/web-server/scribblings/lang.scrbl @@ -27,6 +27,10 @@ provide the following function: Called when this servlet is invoked. The argument is the HTTP request that initiated the servlet. } + +The only way to run Web language servlets currently is to use the +functional interface to starting the server and create a dispatcher +that includes a @scheme[make-lang-dispatcher] dispatcher. @; ------------------------------------------------------------ @section[#:tag "considerations"]{Usage Considerations} diff --git a/collects/web-server/scribblings/managers.scrbl b/collects/web-server/scribblings/managers.scrbl index 777409d0ce..8fddc83edb 100644 --- a/collects/web-server/scribblings/managers.scrbl +++ b/collects/web-server/scribblings/managers.scrbl @@ -146,15 +146,21 @@ deployments of the @web-server . is called if any continuations are expired, with the number of continuations expired. } + +The recommended usage of this manager is codified as the following function: -The recommended use of this manager is to pass, as @scheme[collect?], a -function that checks the memory usage of the system, through -@scheme[current-memory-use]. Then, @scheme[collect-interval] should be sufficiently -large compared to @scheme[check-interval]. This way, if the load on the server -spikes---as indicated by memory usage---the server will quickly expire -continuations, until the memory is back under control. If the load -stays low, it will still efficiently expire old continuations. - -With @href-link["http://continue.cs.brown.edu/" "Continue"], we went from needing to restart the server a few times -a week and having many complaints under load, to not having these complaints -and not needing to restart the server for performance reasons. +@defproc[(create-threshold-LRU-manager + [instance-expiration-handler expiration-handler?] + [memory-threshold number?]) + manager?]{ + This creates an LRU manager with the following behavior: + The memory limit is set to @scheme[memory-threshold]. Continuations start with @scheme[24] + life points. Life points are deducted at the rate of one every @scheme[10] minutes, or one + every @scheme[5] seconds when the memory limit is exceeded. Hence the maximum life time for + a continuation is @scheme[4] hours, and the minimum is @scheme[2] minutes. + + If the load on the server spikes---as indicated by memory usage---the server will quickly expire + continuations, until the memory is back under control. If the load + stays low, it will still efficiently expire old continuations. +} + \ No newline at end of file diff --git a/collects/web-server/scribblings/running.scrbl b/collects/web-server/scribblings/running.scrbl index e009d7db15..62944f194f 100644 --- a/collects/web-server/scribblings/running.scrbl +++ b/collects/web-server/scribblings/running.scrbl @@ -4,11 +4,51 @@ @title[#:tag "run.ss" #:style 'toc]{Running the Web Server} -There are a number of ways to run the Web Server. The two primary ways -are through a command-line tool or through a function call. +There are a number of ways to run the Web Server. They are given in order of simplest to most advanced. @local-table-of-contents[] +@; ------------------------------------------------------------ +@section[#:tag "insta"]{Instant Servlets} +@(require (for-label (only-in web-server/insta/insta + no-web-browser static-files-path))) +@defmodulelang[web-server/insta] + +The fastest way to get a servlet running in the Web server is to use the +"Insta" language in DrScheme. Enter the following into DrScheme: + +@schememod[ +web-server/insta + +(define (start request) + `(html (head (title "Hello world!")) + (body (p "Hey out there!")))) +] + +And press @onscreen["Run"]. A Web browser will open up showing your new servlet. + +Behind the scenes, DrScheme has used @scheme[serve/servlet] to start a new server +that uses your @scheme[start] function as the servlet. +You are given the entire @schememodname[web-server/servlet] API. + +@subsection{Customization API} + +@defmodule[web-server/insta/insta] + +The following API is provided to customize the server instance: + +@defproc[(no-web-browser) void]{ + Calling this will instruct DrScheme to @emph{not} start a Web browser when you press + @onscreen["Run"]. +} + +@defproc[(static-files-path [path path?]) void]{ + This instructs the Web server to serve static files, such as stylesheet and images, from @scheme[path]. +} + +@; ------------------------------------------------------------ +@include-section["servlet-env.scrbl"] + @; ------------------------------------------------------------ @section[#:tag "command-line-tools"]{Command-line Tools} diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index 4f19f1ad5d..ef25f588eb 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -2,30 +2,52 @@ @(require "web-server.ss") @title[#:tag "servlet-env.ss" - #:style 'toc]{Environment} + #:style 'toc]{Simple Single Servlet Servers} @(require (for-label web-server/servlet-env)) @defmodule[web-server/servlet-env] -The @web-server provides a means of running Scheme servlets -from within DrScheme, or any other REPL. +The @web-server provides a way to quickly configure and start a server instance. -@filepath{servlet-env.ss} provides the servlet API from @filepath{servlet.ss} -as well as the following: +@defproc[(serve/servlet [servlet (request? . -> . response?)] + [#:launch-browser? launch-browser? boolean? #t] + [#:quit? quit? boolean? #t] + [#:listen-ip listen-ip string? "127.0.0.1"] + [#:port port number? 8000] + [#:manager manager manager? default-threshold-LRU-manager] + [#:servlet-namespace servlet-namespace (listof require-spec?) empty] + [#:server-root-path server-root-path path? default-server-root-path] + [#:extra-files-path extra-files-path path? (build-path server-root-path "htdocs")] + [#:servlets-root servlets-root path? (build-path server-root-path ".")] + [#:file-not-found-path file-not-found-path path? + (build-path server-root-path "conf" "not-found.html")] + [#:mime-types-path mime-types-path path? + (build-path server-root-path "mime.types")] + [#:servlet-path servlet-path path? + "servlets/standalone.ss"]) + void]{ + This sets up and starts a fairly default server instance. + + @scheme[servlet] is installed as a server at @scheme[servlet-path] with @scheme[manager] + as its continuation manager. (The default manager limits the amount of memory to 64 MB and + deals with memory pressure as discussed in the @scheme[make-threshold-LRU-manager] documentation.) + + If @scheme[launch-browser?] is true, then a web browser is opened to the servlet's start page. + + If @scheme[quit?] is true, then the URL @filepath["/quit"] ends the server. -@defthing[send-url (parameter/c ([url string?] [separate-window? boolean?] . -> . void))]{ - Should open @scheme[url]. In another window if @scheme[separate-window?] is true. - By default this is from @scheme[net/sendurl]. -} - -@defform*[[(on-web servlet-expr) - (on-web port servlet-expr)]]{ - - The first form expands to @scheme[(on-web 8000 servlet-expr)]. - - Constructs a small servlet, where the body of the @scheme[start] procedure is - @scheme[servlet-expr], runs the @web-server on port @scheme[port], and calls - @scheme[send-url] with a URL for the constructed servlet. The call blocks until the - servlet finishes its computation, i.e. @scheme[servlet-expr] is evaluated, and - returns its result. @scheme[servlet-expr] may use the entire Scheme servlet API. + Advanced users may need the following options: + + The server listens on @scheme[listen-ip] and port @scheme[port]. + + The modules specified by @scheme[servlet-namespace] are shared with other servlets. + + The server files are rooted at @scheme[server-root-path] (which is defaultly the distribution root.) + A file path, in addition to the @filepath["htdocs"] directory under @scheme[server-root-path] may be + provided with @scheme[extra-files-path]. These files are checked first. + The @filepath["servlets"] directory is expected at @scheme[servlets-root]. + + If a file cannot be found, @scheme[file-not-found-path] is used as an error response. + + MIME types are looked up at @scheme[mime-types-path]. } diff --git a/collects/web-server/scribblings/servlet.scrbl b/collects/web-server/scribblings/servlet.scrbl index ddd0f7b789..9d227da96b 100644 --- a/collects/web-server/scribblings/servlet.scrbl +++ b/collects/web-server/scribblings/servlet.scrbl @@ -4,9 +4,11 @@ @title[#:tag "servlet" #:style 'toc]{Scheme Servlets} +@defmodule[web-server/servlet] + The @web-server allows servlets to be written in Scheme. It provides the supporting API, described below, for the construction -of these servlets. This API is provided by @filepath{servlet.ss}. +of these servlets. @local-table-of-contents[] @@ -425,5 +427,3 @@ generated. For more information on their semantics, consult the paper Binds @scheme[wc] to @scheme[v] in the current frame, shadowing any other bindings to @scheme[wc] in the current frame. } - -@include-section["servlet-env.scrbl"] diff --git a/collects/web-server/scribblings/web-server.scrbl b/collects/web-server/scribblings/web-server.scrbl index f116352fc1..a8012ab598 100644 --- a/collects/web-server/scribblings/web-server.scrbl +++ b/collects/web-server/scribblings/web-server.scrbl @@ -2,7 +2,8 @@ @(require "web-server.ss") @title[#:tag "web-server-ref"]{@bold{Web Server}: PLT HTTP Server} -@author{Jay McCarthy (jay@"@"plt-scheme.org)} + +By Jay McCarthy (jay@"@"plt-scheme.org) The @web-server collection provides libraries that can be used to develop Web applications in Scheme. @@ -31,8 +32,8 @@ We thank Matthew Flatt for his superlative work on MzScheme. We thank the previous maintainers of the @web-server : Paul T. Graunke, Mike Burns, and Greg Pettyjohn Numerous people have provided invaluable feedback on the server, including Eli Barzilay, Ryan Culpepper, Robby -Findler, Dan Licata, Matt Jadud, Jacob Matthews, Matthias Radestock, Andrey Skylar, -Michael Sperber, Dave Tucker, Anton van Straaten, and Noel Welsh. We also thank the +Findler, Dave Gurnell, Matt Jadud, Dan Licata, Jacob Matthews, Matthias Radestock, Andrey Skylar, +Michael Sperber, Anton van Straaten, Dave Tucker, and Noel Welsh. We also thank the many other PLT Scheme users who have exercised the server and offered critiques. @index-section[] diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index d86210ecde..399f8fdc41 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -1,87 +1,125 @@ +; Derived from plai/web/server, which was based on an older version of this +; Also derived from planet/untyped/instaservlet #lang scheme/base (require (prefix-in net: net/sendurl) - (for-syntax scheme/base) - mzlib/list) -(require "web-server.ss" - "configuration/configuration-table.ss" - "private/util.ss" - "managers/timeouts.ss" - "private/servlet.ss" - "configuration/namespace.ss" - "private/cache-table.ss" - (prefix-in servlets: "dispatchers/dispatch-servlets.ss")) -(require "servlet.ss") -(provide (rename-out [on-web:syntax on-web]) - send-url - (all-from-out "servlet.ss")) + scheme/list) +(require web-server/web-server + web-server/managers/lru + web-server/private/servlet + web-server/configuration/namespace + web-server/private/cache-table + web-server/private/util + web-server/configuration/responders + web-server/dispatchers/dispatch + web-server/private/mime-types + web-server/configuration/configuration-table + (prefix-in lift: web-server/dispatchers/dispatch-lift) + (prefix-in fsmap: web-server/dispatchers/filesystem-map) + (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer) + (prefix-in files: web-server/dispatchers/dispatch-files) + (prefix-in filter: web-server/dispatchers/dispatch-filter) + (prefix-in servlets: web-server/dispatchers/dispatch-servlets)) (define send-url (make-parameter net:send-url)) -; XXX Change to setup temporary file and special dispatcher -(define-syntax (on-web:syntax stx) - (syntax-case stx () - [(on-web:syntax servlet-expr) - (syntax - (on-web:syntax 8000 servlet-expr))] - [(on-web:syntax port servlet-expr) - (with-syntax ([initial-request (datum->syntax (syntax servlet-expr) 'initial-request)]) - (syntax - (on-web (lambda (initial-request) servlet-expr) - port - "servlets/standalone.ss")))])) +(define (quit-server sema) + (lift:make + (lambda (request) + (thread (lambda () (sleep 2) (semaphore-post sema))) + `(html + (head + (title "Server Stopped") + (link ([rel "stylesheet"] [href "/error.css"]))) + (body + (div ([class "section"]) + (div ([class "title"]) "Server Stopped") + (p "Return to DrScheme."))))))) -(define (on-web servlet-expr the-port the-path) +(provide serve/servlet) +(define (serve/servlet new-servlet + #:launch-browser? + [launch-browser? #t] + #:quit? + [quit? #t] + + #:listen-ip + [listen-ip "127.0.0.1"] + #:port + [the-port 8000] + + #:manager + [manager + (make-threshold-LRU-manager + (lambda (request) + `(html (head (title "Page Has Expired.")) + (body (p "Sorry, this page has expired. Please go back.")))) + (* 64 1024 1024))] + + #:servlet-namespace + [servlet-namespace empty] + #:server-root-path + [server-root-path (directory-part default-configuration-table-path)] + #:extra-files-path + [extra-files-path (build-path server-root-path "htdocs")] + #:servlets-root + [servlets-root (build-path server-root-path ".")] + #:file-not-found-path + [file-not-found-path (build-path server-root-path "conf" "not-found.html")] + #:mime-types-path + [mime-types-path (build-path server-root-path "mime.types")] + #:servlet-path + [servlet-path "servlets/standalone.ss"]) (let*-values ([(standalone-url) - (format "http://localhost:~a/~a" the-port the-path)] - [(final-value) - (void)] - [(final-conn) - (void)] - [(sema) - (make-semaphore 0)] - [(make-servlet-namespace) (make-make-servlet-namespace)] - [(new-servlet) - (lambda (initial-request) - (let ([v (servlet-expr initial-request)]) - (set! final-value v) - (semaphore-post sema) - (if (response? v) - v - `(html (head (title "Servlet has ended.")) - (body (p "This servlet has ended, please return to the interaction window."))))))] + (format "http://localhost:~a/~a" the-port servlet-path)] + [(make-servlet-namespace) (make-make-servlet-namespace + #:to-be-copied-module-specs servlet-namespace)] [(the-scripts) (make-cache-table)] - [(clear-cache! servlet-dispatch) - (servlets:make (box the-scripts) - #:make-servlet-namespace make-servlet-namespace - #:url->path - (lambda _ - (values (build-path (directory-part default-configuration-table-path) - "default-web-root" "." - the-path) - empty)))] + [(sema) (make-semaphore 0)] + [(dispatcher) + (sequencer:make + (if quit? + (filter:make + #rx"^/quit$" + (quit-server sema)) + (lambda _ (next-dispatcher))) + (filter:make + #rx"\\.ss" + (let-values ([(clear-cache! servlet-dispatch) + (servlets:make (box the-scripts) + #:make-servlet-namespace make-servlet-namespace + #:url->path + (lambda _ + (values (build-path servlets-root servlet-path) + empty)))]) + servlet-dispatch)) + (files:make + #:url->path (fsmap:make-url->path + extra-files-path) + #:path->mime-type (make-path->mime-type mime-types-path) + #:indices (list "index.html" "index.htm")) + (files:make + #:url->path (fsmap:make-url->path + (build-path server-root-path "htdocs")) + #: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-path)))] [(shutdown-server) - (serve #:dispatch servlet-dispatch + (serve #:dispatch dispatcher + #:listen-ip listen-ip #:port the-port)]) (cache-table-lookup! the-scripts (string->symbol (path->string - (build-path (directory-part default-configuration-table-path) - "default-web-root" "." - the-path))) + (build-path servlets-root servlet-path))) (lambda () (make-servlet (make-custodian) (make-servlet-namespace) - (create-timeout-manager - (lambda (request) - `(html (head "Return to the interaction window.") - (body (p "Return to the interaction window.")))) - 30 30) + manager new-servlet))) - ((send-url) standalone-url #t) - ; Wait for final call + (when launch-browser? + ((send-url) standalone-url #t)) + (printf "Your web application is running at ~a.~n" standalone-url) + (printf "Click 'Stop' at any time to terminate the web server.~n") (semaphore-wait sema) - ; XXX: Find a way to wait for final HTML to be sent - ; Shutdown the server - (shutdown-server) - final-value)) + (shutdown-server))) \ No newline at end of file diff --git a/collects/web-server/tests/servlet-env-test.ss b/collects/web-server/tests/servlet-env-test.ss index 09d89ab17f..f450d730c8 100644 --- a/collects/web-server/tests/servlet-env-test.ss +++ b/collects/web-server/tests/servlet-env-test.ss @@ -7,7 +7,8 @@ mzlib/list mzlib/pretty net/url - web-server/servlet-env) + web-server/servlet-env + web-server/servlet) (provide servlet-env-tests) #;(define (call u bs) @@ -51,9 +52,10 @@ (input ([type "text"] [name "number"] [value ""])) (input ([type "submit"] [name "enter"] [value "Enter"]))))))) (define (example) - (on-web - 9999 - `(html (head (title "Sum")) - (body ([bgcolor "white"]) - (p "The sum is " - ,(number->string (+ (request-number "first") (request-number "second")))))))) + (serve/servlet + (lambda (request) + `(html (head (title "Sum")) + (body ([bgcolor "white"]) + (p "The sum is " + ,(number->string (+ (request-number "first") (request-number "second"))))))) + #:port 9999)) diff --git a/collects/web-server/web-config-unit.ss b/collects/web-server/web-config-unit.ss index b29992b3d3..735a0d16fa 100644 --- a/collects/web-server/web-config-unit.ss +++ b/collects/web-server/web-config-unit.ss @@ -103,7 +103,7 @@ (let ([m (host-table-messages host-table)] [conf (paths-conf paths)]) (make-responders - (gen-servlet-responder (build-path-unless-absolute conf (messages-servlet m))) + servlet-error-responder servlet-loading-responder (gen-authentication-responder (build-path-unless-absolute conf (messages-authentication m))) (gen-servlets-refreshed (build-path-unless-absolute conf (messages-servlets-refreshed m)))