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

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

@ -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
[listen-ip "127.0.0.1"] [listen-ip "127.0.0.1"]
#:port #:port
[the-port 8000] [the-port 8000]
#:manager #:manager
[manager [manager
(make-threshold-LRU-manager (make-threshold-LRU-manager
(lambda (request) (lambda (request)
`(html (head (title "Page Has Expired.")) `(html (head (title "Page Has Expired."))
(body (p "Sorry, this page has expired. Please go back.")))) (body (p "Sorry, this page has expired. Please go back."))))
(* 64 1024 1024))] (* 64 1024 1024))]
#:servlet-path #:servlet-path
[servlet-path "/servlets/standalone.ss"] [servlet-path "/servlets/standalone.ss"]
#:servlet-regexp #:servlet-regexp
[servlet-regexp (regexp (format "^~a$" (regexp-quote servlet-path)))] [servlet-regexp (regexp (format "^~a$" (regexp-quote servlet-path)))]
#:stateless? #:stateless?
[stateless? #f] [stateless? #f]
#:servlet-namespace #:servlet-namespace
[servlet-namespace empty] [servlet-namespace empty]
#:server-root-path #:server-root-path
[server-root-path (directory-part default-configuration-table-path)] [server-root-path (directory-part default-configuration-table-path)]
#:extra-files-paths #:extra-files-paths
[extra-files-paths (list (build-path server-root-path "htdocs"))] [extra-files-paths (list (build-path server-root-path "htdocs"))]
#:servlets-root #:servlets-root
[servlets-root (build-path server-root-path "htdocs")] [servlets-root (build-path server-root-path "htdocs")]
#:servlet-current-directory #:servlet-current-directory
[servlet-current-directory servlets-root] [servlet-current-directory servlets-root]
#:file-not-found-responder #:file-not-found-responder
[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 (gen-file-not-found-responder
[mime-types-path (build-path server-root-path "mime.types")]) (build-path server-root-path "conf" "not-found.html"))]
(define standalone-url #:mime-types-path
(format "http://localhost:~a~a" the-port servlet-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)
@ -145,32 +141,33 @@
(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))

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