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

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

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