diff --git a/collects/web-server/private/text-launch.ss b/collects/web-server/private/text-launch.ss index 0ad4b41f8a..8788e97fac 100644 --- a/collects/web-server/private/text-launch.ss +++ b/collects/web-server/private/text-launch.ss @@ -1,4 +1,5 @@ (module text-launch mzscheme - (require "launch.ss") + (require "launch.ss" + "../web-server.ss") (serve) - (semaphore-wait (make-semaphore))) \ No newline at end of file + (do-not-return)) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/run.ss b/collects/web-server/prototype-web-server/run.ss index cf2986262c..b6b6528d3f 100644 --- a/collects/web-server/prototype-web-server/run.ss +++ b/collects/web-server/prototype-web-server/run.ss @@ -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))) \ No newline at end of file + (do-not-return)) \ No newline at end of file diff --git a/collects/web-server/web-server.ss b/collects/web-server/web-server.ss index fb70f3fc9a..06e4ad70b1 100644 --- a/collects/web-server/web-server.ss +++ b/collects/web-server/web-server.ss @@ -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))))) \ No newline at end of file