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

new units

Browse Source 
svn: r5057
This commit is contained in:
Jay McCarthy 2006-12-07 18:13:49 +00:00
parent fdfdf1bc92
commit 01d27f8ab3
2 changed files with 61 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/web-server/private/launch.ss
View File

@ -3,7 +3,7 @@
(require (lib "cmdline.ss")
(lib "pregexp.ss")
(lib "contract.ss")
(lib "unitsig.ss")
(lib "unit.ss")
(lib "tcp-sig.ss" "net"))
(require "util.ss"
"configuration-structures.ss"
@ -51,14 +51,17 @@
flags))
'()))
(define-values/invoke-unit/sig web-server^
(compound-unit/sig
(import (T : net:tcp^))
(link
[C : web-config^ (configuration@)]
[S : web-server^ (web-server@ T C)])
(export (open S)))
#f net:tcp^)
(define-compound-unit launch@
(import (T : tcp^))
(export S)
(link
[((C : web-config^)) configuration@]
[((S : web-server^)) web-server@ T C]))
(define-values/invoke-unit
launch@
(import tcp^)
(export web-server^))
(provide ; XXX contract
serve))

98
collects/web-server/web-server-unit.ss
View File

@ -17,64 +17,64 @@
(prefix path-procedure: "dispatchers/dispatch-pathprocedure.ss")
(prefix log: "dispatchers/dispatch-log.ss")
(prefix host: "dispatchers/dispatch-host.ss"))
(provide web-server@)
#;(provide/contract
; XXX contract
[web-server@ unit?])
; XXX contract
[web-server@ unit?])
(define-unit web-config@->dispatch-server-config@
(import (prefix config: web-config^))
(export dispatch-server-config^)
(init-depend web-config^)
(define read-request the-read-request)
(define port config:port)
(define listen-ip config:listen-ip)
(define max-waiting config:max-waiting)
(define initial-connection-timeout config:initial-connection-timeout)
;; dispatch : connection request -> void
(define dispatch-cache (make-cache-table))
(define dispatch
(host:make
(lambda (host)
(cache-table-lookup!
dispatch-cache host
(lambda ()
(parameterize ([current-custodian (current-server-custodian)])
(host-info->dispatcher
(config:virtual-hosts (symbol->string host)))))))))
;; host-info->dispatcher : host-info -> conn request -> void
(define (host-info->dispatcher host-info)
(sequencer:make
(log:make #:log-format (host-log-format host-info)
#:log-path (host-log-path host-info))
(passwords:make #:password-file (host-passwords host-info)
#:password-connection-timeout (timeouts-password (host-timeouts host-info))
#:authentication-responder (responders-authentication (host-responders host-info))
#:passwords-refresh-responder (responders-passwords-refreshed (host-responders host-info)))
(path-procedure:make "/conf/collect-garbage"
(lambda ()
(collect-garbage)
((responders-collect-garbage (host-responders host-info)))))
(servlets:make config:instances config:scripts config:make-servlet-namespace
#:servlet-root (paths-servlet (host-paths host-info))
#:responders-servlets-refreshed (responders-servlets-refreshed (host-responders host-info))
#:responders-servlet-loading (responders-servlet-loading (host-responders host-info))
#:responders-servlet (responders-servlet (host-responders host-info))
#:responders-file-not-found (responders-file-not-found (host-responders host-info))
#:timeouts-servlet-connection (timeouts-servlet-connection (host-timeouts host-info))
#:timeouts-default-servlet (timeouts-default-servlet (host-timeouts host-info)))
(files:make #:htdocs-path (paths-htdocs (host-paths host-info))
#:mime-types-path (paths-mime-types (host-paths host-info))
#:indices (host-indices host-info)
#:file-not-found-responder (responders-file-not-found (host-responders host-info))))))
(define read-request the-read-request)
(define port config:port)
(define listen-ip config:listen-ip)
(define max-waiting config:max-waiting)
(define initial-connection-timeout config:initial-connection-timeout)
;; dispatch : connection request -> void
(define dispatch-cache (make-cache-table))
(define dispatch
(host:make
(lambda (host)
(cache-table-lookup!
dispatch-cache host
(lambda ()
(parameterize ([current-custodian (current-server-custodian)])
(host-info->dispatcher
(config:virtual-hosts (symbol->string host)))))))))
;; host-info->dispatcher : host-info -> conn request -> void
(define (host-info->dispatcher host-info)
(sequencer:make
(log:make #:log-format (host-log-format host-info)
#:log-path (host-log-path host-info))
(passwords:make #:password-file (host-passwords host-info)
#:password-connection-timeout (timeouts-password (host-timeouts host-info))
#:authentication-responder (responders-authentication (host-responders host-info))
#:passwords-refresh-responder (responders-passwords-refreshed (host-responders host-info)))
(path-procedure:make "/conf/collect-garbage"
(lambda ()
(collect-garbage)
((responders-collect-garbage (host-responders host-info)))))
(servlets:make config:instances config:scripts config:make-servlet-namespace
#:servlet-root (paths-servlet (host-paths host-info))
#:responders-servlets-refreshed (responders-servlets-refreshed (host-responders host-info))
#:responders-servlet-loading (responders-servlet-loading (host-responders host-info))
#:responders-servlet (responders-servlet (host-responders host-info))
#:responders-file-not-found (responders-file-not-found (host-responders host-info))
#:timeouts-servlet-connection (timeouts-servlet-connection (host-timeouts host-info))
#:timeouts-default-servlet (timeouts-default-servlet (host-timeouts host-info)))
(files:make #:htdocs-path (paths-htdocs (host-paths host-info))
#:mime-types-path (paths-mime-types (host-paths host-info))
#:indices (host-indices host-info)
#:file-not-found-responder (responders-file-not-found (host-responders host-info))))))
(define-compound-unit/infer web-server@
(import tcp^ web-config^)
(export web-server^)
(link web-config@->dispatch-server-config@ dispatch-server@)))