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

various kinds of serve

Browse Source 
svn: r6392
This commit is contained in:
Jay McCarthy 2007-05-29 22:04:20 +00:00
parent e9cc4026b9
commit 833c9cced8
3 changed files with 101 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/web-server/private/text-launch.ss
View File

@ -1,4 +1,5 @@
(module text-launch mzscheme
(require "launch.ss")
(require "launch.ss"
"../web-server.ss")
(serve)
(semaphore-wait (make-semaphore)))
(do-not-return))

47
collects/web-server/prototype-web-server/run.ss
View File

@ -1,11 +1,7 @@
(module run mzscheme
(require (lib "unit.ss")
(lib "tcp-sig.ss" "net"))
(require (lib "dispatch-server-sig.ss" "web-server" "private")
(lib "dispatch-server-unit.ss" "web-server" "private")
(require (lib "web-server.ss" "web-server")
(lib "response.ss" "web-server")
(lib "util.ss" "web-server" "private")
(prefix http: (lib "request.ss" "web-server" "private"))
(prefix files: (lib "dispatch-files.ss" "web-server" "dispatchers"))
(prefix filter: (lib "dispatch-filter.ss" "web-server" "dispatchers"))
(prefix sequencer: (lib "dispatch-sequencer.ss" "web-server" "dispatchers"))
@ -23,12 +19,6 @@
(call-with-input-file path
(lambda (in) (read-string (file-size path) in))))
(define port 8080)
(define listen-ip #f)
(define max-waiting 40)
(define initial-connection-timeout 60)
(define read-request http:read-request)
(define server-root-path (build-path "~" "Development" "plt" "default-web-root"))
(define default-host-path (build-path server-root-path "conf"))
(define htdocs-path (build-path server-root-path "htdocs"))
@ -56,24 +46,19 @@
(list "Servlet didn't load.\n"
(exn->string exn)))))
(define dispatch
(sequencer:make
(filter:make
#rx"\\.ss"
(servlets2:make #:htdocs-path htdocs-path
#:timeouts-servlet-connection 86400
#:responders-servlet-loading responders-servlet-loading
#:responders-servlet responders-servlet
#:responders-file-not-found responders-file-not-found))
(files:make #:htdocs-path htdocs-path
#:mime-types-path (build-path server-root-path "mime.types")
#:indices (list "index.html" "index.htm")
#:file-not-found-responder responders-file-not-found)))
(serve
#:port 8080
#:dispatch (sequencer:make
(filter:make
#rx"\\.ss"
(servlets2:make #:htdocs-path htdocs-path
#:timeouts-servlet-connection 86400
#:responders-servlet-loading responders-servlet-loading
#:responders-servlet responders-servlet
#:responders-file-not-found responders-file-not-found))
(files:make #:htdocs-path htdocs-path
#:mime-types-path (build-path server-root-path "mime.types")
#:indices (list "index.html" "index.htm")
#:file-not-found-responder responders-file-not-found)))
(define-values/invoke-unit
dispatch-server@
(import tcp^ dispatch-server-config^)
(export dispatch-server^))
(define shutdown (serve))
(semaphore-wait (make-semaphore 0)))
(do-not-return))

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

@ -1,18 +1,97 @@
(module web-server mzscheme
(require (lib "tcp-sig.ss" "net")
(require (lib "kw.ss")
(lib "plt-match.ss")
(lib "tcp-sig.ss" "net")
(prefix raw: (lib "tcp-unit.ss" "net"))
(lib "unit.ss")
(lib "contract.ss")
"private/dispatch-server-sig.ss"
"private/dispatch-server-unit.ss"
"web-config-sig.ss"
"web-server-sig.ss"
"web-server-unit.ss"
"configuration.ss"
(prefix http: "private/request.ss")
"private/configuration-structures.ss")
(provide
serve
serve/ports
serve/ips+ports)
(provide/contract
[do-not-return (-> void)]
[serve/web-config@ (configuration? . -> . (-> void?))])
(define (do-not-return)
(semaphore-wait (make-semaphore 0)))
(define/kw (serve
#:key
dispatch
[tcp@ raw:tcp@]
[port 80]
[listen-ip #f]
[max-waiting 40]
[initial-connection-timeout 60]
[read-request http:read-request])
(define-unit-binding a-tcp@
tcp@ (import) (export tcp^))
(define-compound-unit/infer dispatch-server@/tcp@
(import dispatch-server-config^)
(link a-tcp@ dispatch-server@)
(export dispatch-server^))
(define-values/invoke-unit
dispatch-server@/tcp@
(import dispatch-server-config^)
(export dispatch-server^))
(serve))
(define/kw (serve/ports
#:key
dispatch
[tcp@ raw:tcp@]
[ports (list 80)]
[listen-ip #f]
[max-waiting 40]
[initial-connection-timeout 60]
[read-request http:read-request])
(define shutdowns
(map (lambda (port)
(serve #:dispatch dispatch
#:tcp@ tcp@
#:port port
#:listen-ip listen-ip
#:max-waiting max-waiting
#:initial-connection-timeout initial-connection-timeout
#:read-request read-request))
ports))
(lambda ()
(for-each apply shutdowns)))
(define/kw (serve/ips+ports
#:key
dispatch
[tcp@ raw:tcp@]
[ips+ports (list (cons #f (list 80)))]
[max-waiting 40]
[initial-connection-timeout 60]
[read-request http:read-request])
(define shutdowns
(map (match-lambda
[(list-rest listen-ip ports)
(serve/ports #:dispatch dispatch
#:tcp@ tcp@
#:ports ports
#:listen-ip listen-ip
#:max-waiting max-waiting
#:initial-connection-timeout initial-connection-timeout
#:read-request read-request)])
ips+ports))
(lambda ()
(for-each apply shutdowns)))
; serve/config@ : configuration -> (-> void)
(define (serve/web-config@ config@)
(define-unit-from-context tcp@ tcp^)
(define-unit m@ (import web-server^) (export)
(init-depend web-server^)
(serve))
@ -20,5 +99,5 @@
(invoke-unit
(compound-unit/infer
(import)
(link tcp@ c@ web-server@ m@)
(link raw:tcp@ c@ web-server@ m@)
(export)))))