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

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

@ -30,12 +30,9 @@
(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
(title "Server Stopped")
(link ([rel "stylesheet"] [href "/error.css"]))) (link ([rel "stylesheet"] [href "/error.css"])))
(body (body (div ([class "section"])
(div ([class "section"])
(div ([class "title"]) "Server Stopped") (div ([class "title"]) "Server Stopped")
(p "Return to DrScheme."))))))) (p "Return to DrScheme.")))))))
@ -59,7 +56,8 @@
#:servlet-regexp regexp?) #:servlet-regexp regexp?)
. ->* . . ->* .
void)]) void)])
(define (serve/servlet start (define (serve/servlet
start
#:command-line? #:command-line?
[command-line? #f] [command-line? #f]
#:launch-browser? #:launch-browser?
@ -100,22 +98,20 @@
#: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
(gen-file-not-found-responder
(build-path server-root-path "conf" "not-found.html"))]
#:mime-types-path #:mime-types-path
[mime-types-path (build-path server-root-path "mime.types")]) [mime-types-path (build-path server-root-path "mime.types")])
(define standalone-url (define standalone-url (format "http://localhost:~a~a" the-port servlet-path))
(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$"
(quit-server sema))
(lambda _ (next-dispatcher))) (lambda _ (next-dispatcher)))
(filter:make (filter:make
servlet-regexp servlet-regexp
@ -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))