suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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.

Browse Source 
svn: r11246
This commit is contained in:
Jay McCarthy 2008-08-14 19:45:35 +00:00
parent 5ebff2fd07
commit 9e20ad7c46
18 changed files with 381 additions and 136 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
collects/web-server/configuration/responders.ss
View File

@ -5,6 +5,37 @@
(require "../private/response-structs.ss" (require "../private/response-structs.ss"
"../private/request-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)
"<unknown procedure>")
(if (cdr item)
(format "line ~a, column ~a, in file ~a"
(srcloc-line (cdr item))
(srcloc-column (cdr item))
(srcloc-source (cdr item)))
"<unknown location>")))))
(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 ; file-response : nat str str [(cons sym str) ...] -> response
; The server should still start without the files there, so the ; The server should still start without the files there, so the
; configuration tool still runs. (Alternatively, find an work around.) ; 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. ; This is slightly tricky since the (interesting) content comes from the exception.
(define (servlet-loading-responder url exn) (define (servlet-loading-responder url exn)
((error-display-handler) ((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) exn)
(make-response/full 500 "Servlet didn't load" (pretty-exception-response url exn))
(current-seconds)
TEXT/HTML-MIME-TYPE
empty
(list "Servlet didn't load.\n")))
; gen-servlet-not-found : str -> url -> response ; gen-servlet-not-found : str -> url -> response
(define (gen-servlet-not-found file-not-found-file) (define (gen-servlet-not-found file-not-found-file)
(lambda (url) (lambda (url)
(file-response 404 "Servlet not found" file-not-found-file))) (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 ; gen-servlet-responder : str -> url tst -> response
(define (gen-servlet-responder servlet-error-file) (define (gen-servlet-responder servlet-error-file)
(lambda (url exn) (lambda (url exn)
@ -77,9 +111,10 @@
(provide/contract (provide/contract
[file-response ((natural-number/c string? path-string?) (listof header?) . ->* . (response?))] [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-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-servlets-refreshed (path-string? . -> . (-> response?))]
[gen-passwords-refreshed (path-string? . -> . (-> response?))] [gen-passwords-refreshed (path-string? . -> . (-> response?))]
[gen-authentication-responder (path-string? . -> . (url? header? . -> . response?))] [gen-authentication-responder (path-string? . -> . (url? header? . -> . response?))]

25
collects/web-server/default-web-root/htdocs/error.css Normal file
View File

@ -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;
}

2
collects/web-server/dispatchers/dispatch-lang.ss
View File

@ -31,7 +31,7 @@
(define (make #:url->path url->path (define (make #:url->path url->path
#:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)] #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)]
#:responders-servlet-loading [responders-servlet-loading servlet-loading-responder] #: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 ;; dispatch : connection request -> void
(define (dispatch conn req) (define (dispatch conn req)

2
collects/web-server/dispatchers/dispatch-servlets.ss
View File

@ -34,7 +34,7 @@
#:url->path url->path #:url->path url->path
#:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)] #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)]
#:responders-servlet-loading [responders-servlet-loading servlet-loading-responder] #: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]) #:timeouts-default-servlet [timeouts-default-servlet 30])
;; servlet-content-producer: connection request -> void ;; servlet-content-producer: connection request -> void

38
collects/web-server/insta/insta.ss Normal file
View File

@ -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?))
))]))

2
collects/web-server/insta/lang/reader.ss Normal file
View File

@ -0,0 +1,2 @@
(module reader syntax/module-reader
web-server/insta/insta)

30
collects/web-server/managers/lru.ss
View File

@ -5,9 +5,10 @@
"../servlet/servlet-structs.ss") "../servlet/servlet-structs.ss")
(provide/contract (provide/contract
[create-LRU-manager (expiration-handler? number? number? (-> boolean?) [create-LRU-manager (expiration-handler? number? number? (-> boolean?)
#:initial-count number? #:initial-count number?
#:inform-p (number? . -> . void) #:inform-p (number? . -> . void)
. -> . manager?)]) . -> . manager?)]
[make-threshold-LRU-manager (expiration-handler? number? . -> . manager?)])
;; Utility ;; Utility
(define (make-counter) (define (make-counter)
@ -16,6 +17,29 @@
(set! i (add1 i)) (set! i (add1 i))
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 (define-struct (LRU-manager manager) (instance-expiration-handler
; Private ; Private
instances instances

10
collects/web-server/scribblings/configuration.scrbl
View File

@ -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. 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?]{ response?]{
Prints the @scheme[exn] to standard output and responds with a "Servlet didn't load." Gives @scheme[exn] to the @scheme[current-error-handler] and response with a stack trace and a "Servlet didn't load" message.
message.
} }
@defproc[(gen-servlet-not-found (file path-string?)) @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]. 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?)) @defproc[(gen-servlet-responder (file path-string?))
((url url?) (exn any/c) . -> . response?)]{ ((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]. Prints the @scheme[exn] to standard output and responds with a "Servlet error." message with content from @scheme[file].

14
collects/web-server/scribblings/dispatchers.scrbl
View File

@ -311,12 +311,12 @@ a URL that refreshes the password file, servlet cache, etc.}
(make-make-servlet-namespace)] (make-make-servlet-namespace)]
[#:responders-servlet-loading [#:responders-servlet-loading
responders-servlet-loading responders-servlet-loading
((url url?) (exn any/c) . -> . response?) ((url url?) (exn exn?) . -> . response?)
servlet-loading-responder] servlet-loading-responder]
[#:responders-servlet [#:responders-servlet
responders-servlet responders-servlet
((url url?) (exn any/c) . -> . response?) ((url url?) (exn exn?) . -> . response?)
(gen-servlet-responder "servlet-error.html")] servlet-error-responder]
[#:timeouts-default-servlet [#:timeouts-default-servlet
timeouts-default-servlet timeouts-default-servlet
integer? 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-servlet-namespace
make-servlet-namespace? make-servlet-namespace?
(make-make-servlet-namespace)] (make-make-servlet-namespace)]
[#:responders-servlet-loading responders-servlet-loading servlet-loading-responder] [#:responders-servlet-loading responders-servlet-loading
[#:responders-servlet responders-servlet (gen-servlet-responder "servlet-error.html")]) ((url url?) (exn exn?) . -> . response?)
servlet-loading-responder]
[#:responders-servlet responders-servlet
((url url?) (exn exn?) . -> . response?)
servlet-error-responder])
dispatcher?]{ dispatcher?]{
If the request URL contains a serialized continuation, then it is invoked with the 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. request. Otherwise, @scheme[url->path] is used to resolve the URL to a path.

4
collects/web-server/scribblings/lang.scrbl
View File

@ -28,6 +28,10 @@ provide the following function:
The argument is the HTTP request that initiated the servlet. 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} @section[#:tag "considerations"]{Usage Considerations}

26
collects/web-server/scribblings/managers.scrbl
View File

@ -147,14 +147,20 @@ deployments of the @web-server .
continuations expired. continuations expired.
} }
The recommended use of this manager is to pass, as @scheme[collect?], a The recommended usage of this manager is codified as the following function:
function that checks the memory usage of the system, through
@scheme[current-memory-use]. Then, @scheme[collect-interval] should be sufficiently @defproc[(create-threshold-LRU-manager
large compared to @scheme[check-interval]. This way, if the load on the server [instance-expiration-handler expiration-handler?]
spikes---as indicated by memory usage---the server will quickly expire [memory-threshold number?])
continuations, until the memory is back under control. If the load manager?]{
stays low, it will still efficiently expire old continuations. 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.
}
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.

44
collects/web-server/scribblings/running.scrbl
View File

@ -4,11 +4,51 @@
@title[#:tag "run.ss" @title[#:tag "run.ss"
#:style 'toc]{Running the Web Server} #:style 'toc]{Running the Web Server}
There are a number of ways to run the Web Server. The two primary ways There are a number of ways to run the Web Server. They are given in order of simplest to most advanced.
are through a command-line tool or through a function call.
@local-table-of-contents[] @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} @section[#:tag "command-line-tools"]{Command-line Tools}

62
collects/web-server/scribblings/servlet-env.scrbl
View File

@ -2,30 +2,52 @@
@(require "web-server.ss") @(require "web-server.ss")
@title[#:tag "servlet-env.ss" @title[#:tag "servlet-env.ss"
#:style 'toc]{Environment} #:style 'toc]{Simple Single Servlet Servers}
@(require (for-label web-server/servlet-env)) @(require (for-label web-server/servlet-env))
@defmodule[web-server/servlet-env] @defmodule[web-server/servlet-env]
The @web-server provides a means of running Scheme servlets The @web-server provides a way to quickly configure and start a server instance.
from within DrScheme, or any other REPL.
@filepath{servlet-env.ss} provides the servlet API from @filepath{servlet.ss} @defproc[(serve/servlet [servlet (request? . -> . response?)]
as well as the following: [#: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.
@defthing[send-url (parameter/c ([url string?] [separate-window? boolean?] . -> . void))]{ @scheme[servlet] is installed as a server at @scheme[servlet-path] with @scheme[manager]
Should open @scheme[url]. In another window if @scheme[separate-window?] is true. as its continuation manager. (The default manager limits the amount of memory to 64 MB and
By default this is from @scheme[net/sendurl]. 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.
@defform*[[(on-web servlet-expr)
(on-web port servlet-expr)]]{ If @scheme[quit?] is true, then the URL @filepath["/quit"] ends the server.
The first form expands to @scheme[(on-web 8000 servlet-expr)]. Advanced users may need the following options:
Constructs a small servlet, where the body of the @scheme[start] procedure is The server listens on @scheme[listen-ip] and port @scheme[port].
@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 The modules specified by @scheme[servlet-namespace] are shared with other servlets.
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. 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].
} }

6
collects/web-server/scribblings/servlet.scrbl
View File

@ -4,9 +4,11 @@
@title[#:tag "servlet" @title[#:tag "servlet"
#:style 'toc]{Scheme Servlets} #:style 'toc]{Scheme Servlets}
@defmodule[web-server/servlet]
The @web-server allows servlets to be written in Scheme. It The @web-server allows servlets to be written in Scheme. It
provides the supporting API, described below, for the construction 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[] @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 Binds @scheme[wc] to @scheme[v] in the current frame, shadowing any
other bindings to @scheme[wc] in the current frame. other bindings to @scheme[wc] in the current frame.
} }
@include-section["servlet-env.scrbl"]

7
collects/web-server/scribblings/web-server.scrbl
View File

@ -2,7 +2,8 @@
@(require "web-server.ss") @(require "web-server.ss")
@title[#:tag "web-server-ref"]{@bold{Web Server}: PLT HTTP Server} @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 The @web-server collection provides libraries that can be used to
develop Web applications in Scheme. 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 We thank the previous maintainers of the @web-server : Paul T. Graunke, Mike Burns, and Greg Pettyjohn
Numerous people have Numerous people have
provided invaluable feedback on the server, including Eli Barzilay, Ryan Culpepper, Robby provided invaluable feedback on the server, including Eli Barzilay, Ryan Culpepper, Robby
Findler, Dan Licata, Matt Jadud, Jacob Matthews, Matthias Radestock, Andrey Skylar, Findler, Dave Gurnell, Matt Jadud, Dan Licata, Jacob Matthews, Matthias Radestock, Andrey Skylar,
Michael Sperber, Dave Tucker, Anton van Straaten, and Noel Welsh. We also thank the 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. many other PLT Scheme users who have exercised the server and offered critiques.
@index-section[] @index-section[]

174
collects/web-server/servlet-env.ss
View File

@ -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 #lang scheme/base
(require (prefix-in net: net/sendurl) (require (prefix-in net: net/sendurl)
(for-syntax scheme/base) scheme/list)
mzlib/list) (require web-server/web-server
(require "web-server.ss" web-server/managers/lru
"configuration/configuration-table.ss" web-server/private/servlet
"private/util.ss" web-server/configuration/namespace
"managers/timeouts.ss" web-server/private/cache-table
"private/servlet.ss" web-server/private/util
"configuration/namespace.ss" web-server/configuration/responders
"private/cache-table.ss" web-server/dispatchers/dispatch
(prefix-in servlets: "dispatchers/dispatch-servlets.ss")) web-server/private/mime-types
(require "servlet.ss") web-server/configuration/configuration-table
(provide (rename-out [on-web:syntax on-web]) (prefix-in lift: web-server/dispatchers/dispatch-lift)
send-url (prefix-in fsmap: web-server/dispatchers/filesystem-map)
(all-from-out "servlet.ss")) (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)) (define send-url (make-parameter net:send-url))
; XXX Change to setup temporary file and special dispatcher (define (quit-server sema)
(define-syntax (on-web:syntax stx) (lift:make
(syntax-case stx () (lambda (request)
[(on-web:syntax servlet-expr) (thread (lambda () (sleep 2) (semaphore-post sema)))
(syntax `(html
(on-web:syntax 8000 servlet-expr))] (head
[(on-web:syntax port servlet-expr) (title "Server Stopped")
(with-syntax ([initial-request (datum->syntax (syntax servlet-expr) 'initial-request)]) (link ([rel "stylesheet"] [href "/error.css"])))
(syntax (body
(on-web (lambda (initial-request) servlet-expr) (div ([class "section"])
port (div ([class "title"]) "Server Stopped")
"servlets/standalone.ss")))])) (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 (let*-values
([(standalone-url) ([(standalone-url)
(format "http://localhost:~a/~a" the-port the-path)] (format "http://localhost:~a/~a" the-port servlet-path)]
[(final-value) [(make-servlet-namespace) (make-make-servlet-namespace
(void)] #:to-be-copied-module-specs servlet-namespace)]
[(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."))))))]
[(the-scripts) (make-cache-table)] [(the-scripts) (make-cache-table)]
[(clear-cache! servlet-dispatch) [(sema) (make-semaphore 0)]
(servlets:make (box the-scripts) [(dispatcher)
#:make-servlet-namespace make-servlet-namespace (sequencer:make
#:url->path (if quit?
(lambda _ (filter:make
(values (build-path (directory-part default-configuration-table-path) #rx"^/quit$"
"default-web-root" "." (quit-server sema))
the-path) (lambda _ (next-dispatcher)))
empty)))] (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) [(shutdown-server)
(serve #:dispatch servlet-dispatch (serve #:dispatch dispatcher
#:listen-ip listen-ip
#:port the-port)]) #:port the-port)])
(cache-table-lookup! the-scripts (cache-table-lookup! the-scripts
(string->symbol (string->symbol
(path->string (path->string
(build-path (directory-part default-configuration-table-path) (build-path servlets-root servlet-path)))
"default-web-root" "."
the-path)))
(lambda () (lambda ()
(make-servlet (make-custodian) (make-servlet (make-custodian)
(make-servlet-namespace) (make-servlet-namespace)
(create-timeout-manager manager
(lambda (request)
`(html (head "Return to the interaction window.")
(body (p "Return to the interaction window."))))
30 30)
new-servlet))) new-servlet)))
((send-url) standalone-url #t) (when launch-browser?
; Wait for final call ((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) (semaphore-wait sema)
; XXX: Find a way to wait for final HTML to be sent (shutdown-server)))
; Shutdown the server
(shutdown-server)
final-value))

16
collects/web-server/tests/servlet-env-test.ss
View File

@ -7,7 +7,8 @@
mzlib/list mzlib/list
mzlib/pretty mzlib/pretty
net/url net/url
web-server/servlet-env) web-server/servlet-env
web-server/servlet)
(provide servlet-env-tests) (provide servlet-env-tests)
#;(define (call u bs) #;(define (call u bs)
@ -51,9 +52,10 @@
(input ([type "text"] [name "number"] [value ""])) (input ([type "text"] [name "number"] [value ""]))
(input ([type "submit"] [name "enter"] [value "Enter"]))))))) (input ([type "submit"] [name "enter"] [value "Enter"])))))))
(define (example) (define (example)
(on-web (serve/servlet
9999 (lambda (request)
`(html (head (title "Sum")) `(html (head (title "Sum"))
(body ([bgcolor "white"]) (body ([bgcolor "white"])
(p "The sum is " (p "The sum is "
,(number->string (+ (request-number "first") (request-number "second")))))))) ,(number->string (+ (request-number "first") (request-number "second")))))))
#:port 9999))

2
collects/web-server/web-config-unit.ss
View File

@ -103,7 +103,7 @@
(let ([m (host-table-messages host-table)] (let ([m (host-table-messages host-table)]
[conf (paths-conf paths)]) [conf (paths-conf paths)])
(make-responders (make-responders
(gen-servlet-responder (build-path-unless-absolute conf (messages-servlet m))) servlet-error-responder
servlet-loading-responder servlet-loading-responder
(gen-authentication-responder (build-path-unless-absolute conf (messages-authentication m))) (gen-authentication-responder (build-path-unless-absolute conf (messages-authentication m)))
(gen-servlets-refreshed (build-path-unless-absolute conf (messages-servlets-refreshed m))) (gen-servlets-refreshed (build-path-unless-absolute conf (messages-servlets-refreshed m)))