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

Mostly reformatting

Browse Source 
svn: r12524
This commit is contained in:
Eli Barzilay 2008-11-20 02:55:28 +00:00
parent 7c0db197ec
commit 788b94e28b
2 changed files with 107 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -9,7 +9,7 @@
web-server/managers/manager web-server/managers/manager
web-server/private/servlet web-server/private/servlet
web-server/configuration/namespace web-server/configuration/namespace
web-server/private/cache-table web-server/private/cache-table
web-server/http web-server/http
web-server/private/util web-server/private/util
web-server/configuration/responders web-server/configuration/responders
@ -18,10 +18,10 @@
web-server/configuration/configuration-table web-server/configuration/configuration-table
web-server/servlet/setup web-server/servlet/setup
(prefix-in lift: web-server/dispatchers/dispatch-lift) (prefix-in lift: web-server/dispatchers/dispatch-lift)
(prefix-in fsmap: web-server/dispatchers/filesystem-map) (prefix-in fsmap: web-server/dispatchers/filesystem-map)
(prefix-in sequencer: web-server/dispatchers/dispatch-sequencer) (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
(prefix-in files: web-server/dispatchers/dispatch-files) (prefix-in files: web-server/dispatchers/dispatch-files)
(prefix-in filter: web-server/dispatchers/dispatch-filter) (prefix-in filter: web-server/dispatchers/dispatch-filter)
(prefix-in servlets: web-server/dispatchers/dispatch-servlets)) (prefix-in servlets: web-server/dispatchers/dispatch-servlets))
(define send-url (make-parameter net:send-url)) (define send-url (make-parameter net:send-url))
@ -30,93 +30,89 @@
(lift:make (lift:make
(lambda (request) (lambda (request)
(thread (lambda () (sleep 2) (semaphore-post sema))) (thread (lambda () (sleep 2) (semaphore-post sema)))
`(html `(html (head (title "Server Stopped")
(head (link ([rel "stylesheet"] [href "/error.css"])))
(title "Server Stopped") (body (div ([class "section"])
(link ([rel "stylesheet"] [href "/error.css"]))) (div ([class "title"]) "Server Stopped")
(body (p "Return to DrScheme.")))))))
(div ([class "section"])
(div ([class "title"]) "Server Stopped")
(p "Return to DrScheme.")))))))
(provide/contract (provide/contract
[serve/servlet (((request? . -> . response?)) [serve/servlet (((request? . -> . response?))
(#:command-line? boolean? (#:command-line? boolean?
#:launch-browser? boolean? #:launch-browser? boolean?
#:quit? boolean? #:quit? boolean?
#:banner? boolean? #:banner? boolean?
#:listen-ip string? #:listen-ip string?
#:port number? #:port number?
#:manager manager? #:manager manager?
#:servlet-namespace (listof module-path?) #:servlet-namespace (listof module-path?)
#:server-root-path path? #:server-root-path path?
#:stateless? boolean? #:stateless? boolean?
#:extra-files-paths (listof path?) #:extra-files-paths (listof path?)
#:servlets-root path? #:servlets-root path?
#:file-not-found-responder (request? . -> . response?) #:file-not-found-responder (request? . -> . response?)
#:mime-types-path path? #:mime-types-path path?
#:servlet-path string? #:servlet-path string?
#:servlet-regexp regexp?) #:servlet-regexp regexp?)
. ->* . . ->* .
void)]) void)])
(define (serve/servlet start (define (serve/servlet
#:command-line? start
[command-line? #f] #:command-line?
#:launch-browser? [command-line? #f]
[launch-browser? (not command-line?)] #:launch-browser?
#:quit? [launch-browser? (not command-line?)]
[quit? (not command-line?)] #:quit?
#:banner? [quit? (not command-line?)]
[banner? (not command-line?)] #:banner?
[banner? (not command-line?)]
#:listen-ip
[listen-ip "127.0.0.1"] #:listen-ip
#:port [listen-ip "127.0.0.1"]
[the-port 8000] #:port
[the-port 8000]
#:manager
[manager #:manager
(make-threshold-LRU-manager [manager
(lambda (request) (make-threshold-LRU-manager
`(html (head (title "Page Has Expired.")) (lambda (request)
(body (p "Sorry, this page has expired. Please go back.")))) `(html (head (title "Page Has Expired."))
(* 64 1024 1024))] (body (p "Sorry, this page has expired. Please go back."))))
(* 64 1024 1024))]
#:servlet-path
[servlet-path "/servlets/standalone.ss"] #:servlet-path
#:servlet-regexp [servlet-path "/servlets/standalone.ss"]
[servlet-regexp (regexp (format "^~a$" (regexp-quote servlet-path)))] #:servlet-regexp
#:stateless? [servlet-regexp (regexp (format "^~a$" (regexp-quote servlet-path)))]
[stateless? #f] #:stateless?
[stateless? #f]
#:servlet-namespace
[servlet-namespace empty] #:servlet-namespace
#:server-root-path [servlet-namespace empty]
[server-root-path (directory-part default-configuration-table-path)] #:server-root-path
#:extra-files-paths [server-root-path (directory-part default-configuration-table-path)]
[extra-files-paths (list (build-path server-root-path "htdocs"))] #:extra-files-paths
#:servlets-root [extra-files-paths (list (build-path server-root-path "htdocs"))]
[servlets-root (build-path server-root-path "htdocs")] #:servlets-root
#:servlet-current-directory [servlets-root (build-path server-root-path "htdocs")]
[servlet-current-directory servlets-root] #:servlet-current-directory
#:file-not-found-responder [servlet-current-directory servlets-root]
[file-not-found-responder (gen-file-not-found-responder (build-path server-root-path "conf" "not-found.html"))] #:file-not-found-responder
#:mime-types-path [file-not-found-responder
[mime-types-path (build-path server-root-path "mime.types")]) (gen-file-not-found-responder
(define standalone-url (build-path server-root-path "conf" "not-found.html"))]
(format "http://localhost:~a~a" the-port servlet-path)) #:mime-types-path
[mime-types-path (build-path server-root-path "mime.types")])
(define standalone-url (format "http://localhost:~a~a" the-port servlet-path))
(define make-servlet-namespace (define make-servlet-namespace
(make-make-servlet-namespace (make-make-servlet-namespace #:to-be-copied-module-specs servlet-namespace))
#:to-be-copied-module-specs servlet-namespace))
(define sema (make-semaphore 0)) (define sema (make-semaphore 0))
(define servlet-box (box #f)) (define servlet-box (box #f))
(define dispatcher (define dispatcher
(sequencer:make (sequencer:make
(if quit? (if quit?
(filter:make (filter:make #rx"^/quit$" (quit-server sema))
#rx"^/quit$" (lambda _ (next-dispatcher)))
(quit-server sema))
(lambda _ (next-dispatcher)))
(filter:make (filter:make
servlet-regexp servlet-regexp
(servlets:make (servlets:make
@ -129,8 +125,8 @@
#:additional-specs #:additional-specs
default-module-specs)]) default-module-specs)])
(if stateless? (if stateless?
(make-stateless.servlet servlet-current-directory start) (make-stateless.servlet servlet-current-directory start)
(make-v2.servlet servlet-current-directory manager start)))]) (make-v2.servlet servlet-current-directory manager start)))])
(set-box! servlet-box servlet) (set-box! servlet-box servlet)
servlet))))) servlet)))))
(let-values ([(clear-cache! url->servlet) (let-values ([(clear-cache! url->servlet)
@ -144,33 +140,34 @@
(servlets:make url->servlet)) (servlets:make url->servlet))
(apply sequencer:make (apply sequencer:make
(map (lambda (extra-files-path) (map (lambda (extra-files-path)
(files:make (files:make
#:url->path (fsmap:make-url->path #:url->path (fsmap:make-url->path extra-files-path)
extra-files-path)
#:path->mime-type (make-path->mime-type mime-types-path) #:path->mime-type (make-path->mime-type mime-types-path)
#:indices (list "index.html" "index.htm"))) #:indices (list "index.html" "index.htm")))
extra-files-paths)) extra-files-paths))
(files:make (files:make
#:url->path (fsmap:make-url->path #:url->path (fsmap:make-url->path (build-path server-root-path "htdocs"))
(build-path server-root-path "htdocs")) #:path->mime-type (make-path->mime-type
#:path->mime-type (make-path->mime-type (build-path server-root-path "mime.types")) (build-path server-root-path "mime.types"))
#:indices (list "index.html" "index.htm")) #:indices (list "index.html" "index.htm"))
(lift:make file-not-found-responder))) (lift:make file-not-found-responder)))
(define shutdown-server (define shutdown-server
(serve #:dispatch dispatcher (serve #:dispatch dispatcher
#:listen-ip listen-ip #:listen-ip listen-ip
#:port the-port)) #:port the-port))
(define welcome
(if banner?
(lambda ()
(printf "Your Web application is running at ~a.\n" standalone-url)
(printf "Click 'Stop' at any time to terminate the Web Server.\n"))
(void)))
(define (bye)
(when banner? (printf "\nWeb Server stopped.\n"))
(shutdown-server))
(when launch-browser? (when launch-browser?
((send-url) standalone-url #t)) ((send-url) standalone-url #t))
(when banner? (welcome)
(printf "Your Web application is running at ~a.~n" standalone-url) (with-handlers ([exn:break? (lambda (exn) (bye))])
(printf "Click 'Stop' at any time to terminate the Web Server.~n"))
(with-handlers
([exn:break?
(lambda (exn)
(when banner?
(printf "~nWeb Server stopped.~n"))
(shutdown-server))])
(semaphore-wait/enable-break sema)) (semaphore-wait/enable-break sema))
; We shouldn't get here, because nothing posts to the semaphore. But just in case... ;; We can get here if a /quit url is visited
(shutdown-server)) (bye))

24
collects/web-server/web-server.ss
View File

@ -15,25 +15,25 @@
[serve [serve
(->* (#:dispatch dispatcher/c) (->* (#:dispatch dispatcher/c)
(#:tcp@ unit? (#:tcp@ unit?
#:port number? #:port number?
#:listen-ip (or/c false/c string?) #:listen-ip (or/c false/c string?)
#:max-waiting number? #:max-waiting number?
#:initial-connection-timeout number?) #:initial-connection-timeout number?)
(-> void))] (-> void))]
[serve/ports [serve/ports
(->* (#:dispatch dispatcher/c) (->* (#:dispatch dispatcher/c)
(#:tcp@ unit? (#:tcp@ unit?
#:ports (listof number?) #:ports (listof number?)
#:listen-ip (or/c false/c string?) #:listen-ip (or/c false/c string?)
#:max-waiting number? #:max-waiting number?
#:initial-connection-timeout number?) #:initial-connection-timeout number?)
(-> void))] (-> void))]
[serve/ips+ports [serve/ips+ports
(->* (#:dispatch dispatcher/c) (->* (#:dispatch dispatcher/c)
(#:tcp@ unit? (#:tcp@ unit?
#:ips+ports (listof (cons/c (or/c false/c string?) (listof number?))) #:ips+ports (listof (cons/c (or/c false/c string?) (listof number?)))
#:max-waiting number? #:max-waiting number?
#:initial-connection-timeout number?) #:initial-connection-timeout number?)
(-> void))] (-> void))]
[do-not-return (-> void)] [do-not-return (-> void)]
[serve/web-config@ ((unit?) (#:tcp@ unit?) . ->* . (-> void?))]) [serve/web-config@ ((unit?) (#:tcp@ unit?) . ->* . (-> void?))])
@ -59,7 +59,7 @@
dispatch-server@/tcp@ dispatch-server@/tcp@
(import dispatch-server-config^) (import dispatch-server-config^)
(export dispatch-server^)) (export dispatch-server^))
(serve)) (serve))
(define (serve/ports (define (serve/ports