From 01d27f8ab3168332bfaab340bd9a6efb48cce343 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 7 Dec 2006 18:13:49 +0000 Subject: [PATCH] new units svn: r5057 --- collects/web-server/private/launch.ss | 21 +++--- collects/web-server/web-server-unit.ss | 98 +++++++++++++------------- 2 files changed, 61 insertions(+), 58 deletions(-) diff --git a/collects/web-server/private/launch.ss b/collects/web-server/private/launch.ss index e6f80f0b25..009def720d 100644 --- a/collects/web-server/private/launch.ss +++ b/collects/web-server/private/launch.ss @@ -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)) \ No newline at end of file diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index 166a3b5f5a..304837c488 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -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@))) - +